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

Compare commits

base: 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
..
compare: scsh-conservatory:http-1-1
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

102 Commits
main ... http-1-1

Author SHA1 Message Date
vibr bccf27785d rename READ-AND-DISCARD-TRAILER to DISCARD-TRAILER for naming consistency 2005-04-20 11:40:23 +00:00
vibr d06479ee4b adapt httpd-handler-lib-interface and httpd-handler structure to 
implementation of chunked transfer coding in handler-lib
 2005-04-16 20:49:29 +00:00
vibr 15049e1c58 implementing chunked transfer coding: 
*new proc  READ-MESSAGE-BODY: a high-level interface for reading in
message bodies (should be used by all handlers)
*new proc READ-ORDINARY-BODY: reads in message bodies with no transfer
coding applied
*new proc READ-CHUNKED-BODY: reads in message bodies in chunked
transfer coding
*new proc GET-CHUNK-SIZE: reads in and parses the size of the next
chunk in a chunked message body
*helper procs READ-AND-DISCARD-TRAILER and DISCARD-LINE-TERMINATOR
*minor changes to GET-NUMERIC-FIELD-VALUE (cosmetic)
 2005-04-16 20:45:33 +00:00
vibr 555d52806d modify seval-handler: 
*don't use concept of reader-writer-body (which is broken), use
writer-body instead -> seval-handler now works correctly
*use new interface READ-MESSAGE-BODY from handler-lib for reading in the
message body
*rename READ-REQUEST-SEXP to PARSE-REQUEST-SEXP
*catch errors thrown by READ in PARSE-REQUEST-SEXP to answer 400
instead of 500 for requests whose message body doesn't contain a valid
s-expression
 2005-04-16 20:33:35 +00:00
vibr 36db985453 in PARSE-HTTP-REQUEST: catch errors thrown by READ-RFC822-HEADERS and 
answer 400 instead of 500 for requests with bad headers
 2005-04-16 20:22:41 +00:00
vibr 0554b2d494 move copyright declarations to COPYING 2005-04-16 20:19:32 +00:00
vibr 630c77d83f syntax of comma separated list which is the field value of the 
Transfer-Encoding header: needs a single SP less
 2005-04-15 15:50:30 +00:00
vibr d174ad3954 add a copy of the regexp definitions HEX and ESCAPED from structure 
url to resolve mutual dependency
 2005-04-15 15:34:48 +00:00
vibr 184c284c4a move these procs from lib/sunet-utilities to httpd/handler-lib: 
GET-SOCKET-HOST-STRING
GET-NUMERIC-FIELD-VALUE
GET-BODY-LENGTH-FROM-CONTENT-LENGTH
CHUNKED-TRANSFER-CODING?
reason: they are httpd-specific in using httpd's data types
 2005-04-15 15:23:32 +00:00
vibr d915722a9b implementing chunked transfer coding: 
* new predicate CHUNKED-TRANSFER-CODING?
 tests wether a request's entity body is sent in chunked
 transfer-encoding
 2005-04-15 12:31:43 +00:00
vibr 4c1e1a16a8 trivia: towards a more modern HTML: closing slash within empty HTML 
elements
*new: EMIT-EMPTY-TAG
*use EMIT-EMPTY-TAG instead of EMIT-TAG where appropriate
 2005-04-14 21:15:21 +00:00
vibr e8dc69b745 we must send a "Connection: close" header as long as we don't support 
persistent connections
 2005-04-14 19:17:16 +00:00
vibr db826a9c1f add comment explaining why the concept of http-reader-writer-body 
(which is used by the seval-handler only) doesn't work
 2005-04-14 15:18:54 +00:00
vibr 8e7e071db2 fix MAKE-CLF (which prepended superfluous slash to requested resource) 2005-04-14 14:42:03 +00:00
vibr 9d3ddd79b9 *delete GET-SOCKET-HOSTNAME-AND-PORTNUMBER (was buggy anyway) 
*rewrite GET-SOCKET-HOST-STRING
 2005-04-14 14:06:00 +00:00
vibr 8974332da1 Location header must be an absolute URL: 
*adapt file-dir-handler's 301 response
*new procs GET-SOCKET-HOSTNAME-AND-PORTNUMBER, GET-SOCKET-HOST-STRING
 2005-04-14 11:38:37 +00:00
vibr 96b485294f *new predicate ABSOLUTE-URL? 
*remove URI-HAS-PROTOCOL?
 2005-04-14 11:32:38 +00:00
vibr f605367c1a answer 400 (Bad Request) for 1.1-Requests which don't include a Host 
header:
*new proc CHECK-HOST-HEADER
 2005-04-13 20:53:53 +00:00
vibr 453a7cdde6 correct call of http-error in MAKE-HOST-NAME-HANDLER 2005-04-13 20:48:57 +00:00
vibr 97f730075d trivia: formatting of error responses 2005-04-13 20:46:40 +00:00
vibr 40d7c923a2 answer 505 (Version not supported) for requests with major version > 
implemented version:
*new proc CHECK-MAJOR-HTTP-VERSION
*new case in MAKE-ERROR-RESPONSE
 2005-04-13 19:35:22 +00:00
vibr fe6b3fffac change URL-Parser's interface: parser now preserves info whether 
Request-URI's path ends with a slash.
(See http://httpd.apache.org/docs-2.0/misc/rewriteguide.html ->
"Trailing slash problem" for reasons).
 2005-04-13 10:32:29 +00:00
vibr 9118345aaa typos 2005-04-13 10:25:14 +00:00
vibr 33b3eb8df7 better documentation of HTTP-URL->URL-STRING and HTTP-URL-PATH->PATH-STRING 2005-04-10 15:30:32 +00:00
vibr d209db26d8 document new URL parser 2005-04-10 15:17:50 +00:00
vibr 0c7c957f2b add comment 2005-04-10 15:15:55 +00:00
vibr a44c53bc67 typos + emphasis 2005-04-10 13:14:02 +00:00
vibr e9bc839cd5 finally adapt documentation to new uri lib procs 2005-04-10 13:03:33 +00:00
vibr 90fc61473e add comment on assumptions about entity in request to seval-handler 2005-04-06 22:49:50 +00:00
vibr c9c45eae6e better comment 2005-04-06 22:47:14 +00:00
vibr 9342e0e593 *replace call of PARSE-REQUEST-URI (relict of old URL parser) 
with call of URL-STRING->HTTP-URL
 2005-04-06 22:45:48 +00:00
vibr 2dcdd41ed9 *reinsert lost line 
*replace calls of UNESCAPE-URI (relict of old URL parser) with UNESCAPE
*simplify URI-HAS-PROTOCOL?
 2005-04-06 22:43:53 +00:00
vibr 512ccfaed3 removal of old URL parser relicts: 
*replace calls of UNESCAPE-URI with UNESCAPE
*remove imports of uri package where no longer needed
 2005-04-06 22:41:10 +00:00
vibr ed53670895 *add comment explaining why we don't need to support "*" and authority 
Request-URIS
*comment on when unescaping is done
*don't unescape query when building a http-url record
*don't escape query when unparsing a http-url record.
*remove PARSED-URI->HTTP-URL, integrate its code into
URL-STRING->HTTP-URL
*add dummy encoder ESCAPE-NOT-UNRESERVED-CHARS
 2005-04-06 22:31:33 +00:00
vibr 745a123735 adapt code to remove calls of URI-PATH->URI (relict of old URL parser) 2005-04-06 12:32:17 +00:00
vibr 61a63b4d4b adapt URI-HAS-PROTOCOL? to new URL parser 2005-04-06 11:59:05 +00:00
vibr 0de6fe79b4 replace calls of HTTP-URL->STRING (relict of old URL parser) 
with calls of HTTP-URL->URL-STRING
 2005-04-06 11:44:28 +00:00
vibr 17a46a7e71 rename URI-STRING->HTTP-URL to URL-STRING->HTTP-URL 2005-04-06 11:35:37 +00:00
vibr 5836ae567b export HTTP-URL-PATH->PATH-STRING in url-interface 2005-04-05 18:45:53 +00:00
vibr 9399bf9397 remove MY-REPORTED-PORT (relict of old URL parser) 2005-04-05 18:45:02 +00:00
vibr da10de6309 add function HTTP-URL-PATH->PATH-STRING (unparses path in http-url record into string) 2005-04-05 18:43:23 +00:00
vibr e5c8cae17f rename HTTP-URL->URI-STRING to HTTP-URL->URL-STRING 2005-04-05 10:59:13 +00:00
vibr 1e93a6cb9f rename PARSE-URI to PARSE-URL 2005-04-05 10:50:12 +00:00
vibr c3b855ae22 minor changes: 
*HTTP1.1 (this is wishful thinking)
*we don't have a general URI parser, just a URL parser
*typos
*alles irdische hat einen namen
 2005-04-04 21:23:16 +00:00
vibr 3548b25c26 rename HTTP-URL-SEARCH to HTTP-URL-QUERY (adaption to restructured 
http-url type in url.scm)
 2005-04-04 21:13:35 +00:00
vibr d0c64d371a further restrict url-interface 2005-04-04 21:10:05 +00:00
vibr 46645ccd58 *remove definition of PARSE-REQUEST-URI (relict of Olin's old URL parser) 
*use URI-STRING->HTTP-URL instead
 2005-04-04 21:07:55 +00:00
vibr d864e4da80 correct reference in comment 2005-04-04 20:57:36 +00:00
vibr cf747a97b4 *add solution for mistake in RFC 2616 (where query part of 
Request-URIs is only allowed for absoluteURIs)
*rename PARSE-HTTP-URL to URI-STRING->HTTP-URL
 2005-04-04 15:35:50 +00:00
vibr ba78eba433 *add comment on another mistake in RFC 2616 (query part of 
Request-URIs only allowed for absoluteURIs)
*add copy of Appendix A of RFC 2396 for convenience
 2005-04-04 13:36:54 +00:00
vibr 69948e9561 adapt definitions of interfaces and structures to new URI 
parsing framework
 2004-10-18 18:33:19 +00:00
vibr ed1e4428c5 *move general procedures ESCAPE, UNESCAPE and their helper procs from 
url.scm to uri.scm
-->Parser/Unparser for HTTP 1.1 URIs is now complete and resides in
url.scm; Encoder/Decoder applicable to URIs in general resides in uri.scm.
(All has been rewritten from scratch, next to nothing of Olin's code
is left).
<--
 2004-10-18 18:23:03 +00:00
vibr 584bfa2cdb *work around scsh bug (?) in definition of charset UNRESERVED 
*new procs for encoding URIs:
-general proc ESCAPE taking an RegExp representing forbidden chars as argument
-specialized procs ESCAPE-SEGMENT, ESCAPE-QUERY
*new helper proc ASCII->ESCAPED
*use ESCAPE-SEGMENT and ESCAPE-URI in HTTP-URL->URI-STRING
 2004-10-18 17:35:40 +00:00
vibr c48446ba7f *remove ESCAPE-URI (didn't reliably differentiate between different portions of 
a URI)
*move INT->HEXCHAR to url.scm
 2004-10-18 16:37:32 +00:00
vibr 44a8ef28be *new procedure UNESCAPE (unescape URI-components using RegExps) 
*move HEXCHAR->INT from uri.scm to here
*use UNESCAPE in PARSED-URI->HTTP-URL
 2004-10-14 17:18:24 +00:00
vibr 9e71b351d4 *remove UNESCAPE-URI, HEX-DIGIT? 
*move HEXCHAR->INT to url.scm
 2004-10-14 17:14:44 +00:00
vibr 932f03a638 *fix two typos in RegExps 
*better comments for PARSE-URI, SPLIT-PATH
*make SPLIT-PATH really accept PARSE-URI's return values
*restructure record-type HTTP-URL
*new procedure PARSED-URI->HTTP-URL
*rewrite PARSE-HTTP-URL to use PARSE-URI and PARSED-URI->HTTP-URL
*remove out-dated comments
*remove out-dated procedure PARSE-HTTP-URL-STRING
*remove DEFAULT-HTTP-SERVER (relict of server record-type)
*rewrite HTTP-URL->STRING
*rename HTTP-URL->STRING to HTTP-URL->URI-STRING
 2004-10-11 17:01:32 +00:00
vibr fe08e779f0 remove record-type server and associated procedures 
(being a relict of parsing of general URIs)
 2004-10-11 09:05:24 +00:00
vibr 41d3e29766 *add comment on how ambiguous definition of Request_URIs in RFC 2616 
is 'solved' by uri-parser

*add comment on record-type server and associated procedures
 2004-10-11 08:54:41 +00:00
vibr 8de8e01f0d adapt documentation to reflect removal of old uri-parser and addition 
of new one
 2004-10-10 18:30:45 +00:00
vibr a1e79c4fc7 parse HTTP 1.1 URIs: 
* add RegExps
* add proc PARSE-URI
* add proc SPLIT-ABS-PATH
 2004-10-06 19:10:49 +00:00
vibr d9950a9b0b remove PARSE-URI from exports of module uri 2004-10-06 19:08:19 +00:00
vibr 2cb8502f9e remove uri-parser PARSE-URI 
(completely out-of-date, has never seen RFC 2396)
 2004-10-06 13:33:45 +00:00
vibr 649f374e8b add comment on uri-parser 2004-10-06 13:29:06 +00:00
vibr 53e3e9672f adapt to RFC terminology: 
rename PARSE-HTTP-SERVERS-URL-FRAGMENT to PARSE-REQUEST-URI
rename variable uri-string to request-uri
 2004-10-05 10:24:29 +00:00
vibr cd22ab11d4 Corrected bug: SEVAL now generates a response-body even if the request's body isn't 
form-url encoded or doesn't contain a program
 2004-08-15 12:44:55 +00:00
vibr 38f2594ba5 emit less newlines 2004-08-15 12:40:06 +00:00
vibr 35565068fb char-set:blank = LWS from RFC 2616 (after folding) 2004-08-15 12:02:36 +00:00
vibr ffac0ebcac simplified get-numeric-field-value (now uses string-trim-both), 
adapted packages.scm
 2004-08-15 11:49:15 +00:00
vibr 8bf71fc3a5 get-numeric-field-value: correct error message 2004-08-15 11:06:39 +00:00
vibr 44100cbf5e Added type NO-BODY for responses which must not contain a message-body 
(201, 304, 404). Added export of type-predicate no-body?.  Adapted
SEND-HTTP-RESPONSE to check for no-body responses. Extended
MAKE-ERROR-RESPONSE to make responses 201, 304, 404.
 2004-08-15 11:03:28 +00:00
vibr 0bb601a0e0 make server-generated webpages XHTML 1.0 Strict: emit prolog 
(not tested)
 2004-08-14 22:08:07 +00:00
vibr 549594bef4 with-tag* outputs no newlines 2004-08-14 22:05:06 +00:00
vibr ef48e4e5ae make-host-name-handler now uses get-header from sunet-utilities.scm 2004-08-14 22:03:19 +00:00
vibr 8cf841bad3 rename get-content-length to get-body-length-from-content-length 
move get-body-length-from-content-length and get-numeric-field-value
from seval.scm to sunet-utilities.scm

adapt packages.scm
 2004-08-14 21:58:11 +00:00
vibr f8559581d2 GET-NUMERIC-FIELD-VALUE now uses GET-HEADER from utilities.scm 
and returns #f if GET-HEADER does so

adapted GET-CONTENT-LENGHT
 2004-08-14 21:18:12 +00:00
vibr aea0e950ba removed definition of GET-HEADER which conflicted with definition of 
GET-HEADER in utilities.scm and wasn't exported anyway
 2004-08-14 20:54:57 +00:00
vibr ffbe3b21cd factor out parsing of content-length header value -> GET-CONTENT-LENGTH 
generalize parsing of content-length header value to parse all header field
values of the form 1*DIGIT -> GET-NUMERIC-FIELD-VALUE

check for valid content-length header in SEVAL before answering 200

TODO: SEVAL is still buggy for request with invalid _body_
 2004-08-14 19:07:23 +00:00
vibr 9fcfcf36f0 add comments explaining why seval-handler is buggy 2004-08-14 15:47:29 +00:00
vibr 06ec0f0293 server-generated webpages -> XHTML 1.0 Strict: 
add XML namespace declaration to html element
 2004-08-13 15:49:19 +00:00
vibr 6969b80206 - move XHTML stuff from responses.scm to htmlout.scm 
- new function EMIT-PROLOG
- define XML namespace declaration
- adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr
(this is not nice, but the only alternative was hard-coding the XML
namespace declaration into the various handlers)
- element names -> lower case
 2004-08-13 15:46:53 +00:00
vibr 96f0ae41d5 -move XHTML stuff from responses.scm to htmlout.scm 
-don't use WRITE-STRING with \n (\n within strings is not in R5RS),
instead use FORMAT with ~%
-use EMIT-PROLOG and EMIT-TAG from htmlout.scm
 2004-08-13 15:37:31 +00:00
vibr c089e26e96 move XHTML stuff from responses.scm to htmlout.scm, adapt 
packages.scm
 2004-08-13 15:34:00 +00:00
vibr a9ae5061d0 make server generated html pages XHTML 1.0 Strict: 
element names -> lower case
 2004-08-13 15:26:50 +00:00
vibr 4d7f10960c fix typo 2004-08-11 19:38:16 +00:00
vibr 7bdd94cdb5 "moved-temp" -> "temp-redirect" 
(HTTP/1.1: use 307 instead of 302 for unambiguity)
 2004-08-11 19:06:05 +00:00
vibr 7b6f5675af allow header in 405 answers 2004-08-11 14:53:11 +00:00
vibr 880a05229c -adapt calls of make-error-response 
-allow header in 405 answers
-answer 501, not 405, for unimplemented/unrecognized methods
 2004-08-11 14:51:51 +00:00
vibr 5f64e72cd0 make-error-response: 
more meaningful error description: show parsed uri
 2004-08-11 14:48:11 +00:00
vibr 3abe557a86 make-error-response in response.scm uses http-url->string 2004-08-11 14:45:32 +00:00
vibr 8b09f2b338 -adapt calls of make-error-response 
-answer 501, not 405, for unimplemented/unrecognized methods
 2004-08-11 12:28:46 +00:00
vibr 1c4445933d adapt docu of make-error-response to its reworked interface 2004-08-11 10:43:26 +00:00
vibr f22f43ccd1 make-error-response: 
use stuff in req where req isn't #f
 2004-08-11 10:17:14 +00:00
vibr 2ee378aea9 add comments: 
-make clear difference between http-error and
fatal-syntax-error
-refer to make-error-response for args of http-error
 2004-08-11 09:20:31 +00:00
vibr a3dd880c7a +catch calls of make-error-response with too few arguments 2004-08-10 14:26:50 +00:00
vibr 4b37826de8 +comment/question 2004-08-10 14:25:55 +00:00
vibr 1bdac52ad6 adapt calls of make-error-response: remove tautologous description of errors 2004-07-30 22:26:50 +00:00
vibr 7c7be57a22 changes to make-error-response: 
(1)no special treatment of first "optional" argument
- rationale: a different number of args is required depending on the
specific error code

(2)use close-html to write out all _effectively_ optional args

(3)generated html-pages are valid XHTML 1.0 Strict

(4)require header Allow for 405 errors

(5)more exact descriptions of errors in generated html-pages

TODO: handle calls of make-error-response with too little args
 2004-07-30 22:25:03 +00:00
vibr 63e4761c58 adapt calls of make-error-response: 
no URI header field in 1.1
 2004-07-29 16:09:31 +00:00
vibr 5e14a326b9 adapt make-error-response: 
- no URI header field in 1.1
- new 30x status codes in 1.1
 2004-07-29 16:08:30 +00:00
vibr 1b4bdb59c6 updated status codes 2004-07-16 15:09:55 +00:00
vibr f96d93b355 re-commit revision 1.22, this time to branch http-1-1 2004-05-27 14:47:46 +00:00
81 changed files with 1980 additions and 9674 deletions
Show Stats Expand all files Collapse all files

10
COPYING
View File

@ -1,8 +1,10 @@
Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
Copyright (c) 1996-2004 by Mike Sperber.
Copyright (c) 1999-2004 by Martin Gasbichler.
Copyright (c) 1998-2004 by Eric Marsden.
Copyright (c) 2001-2004 by Andreas Bernauer
Copyright (c) 1995-1996 by 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) 2001-2003 by Andreas Bernauer.
Copyright (c) 2004-2005 by Viola Brunner.
All rights reserved.
Redistribution and use in source and binary forms, with or without

5
INSTALL
View File

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

20
README
View File

@ -4,20 +4,20 @@ The Scheme Untergrund Networking Package (SUnet, for short) is a
collection of applications and libraries for Internet hacking in
Scheme. It contains over 15000 lines of high-quality Scheme code that
runs under Scsh, the Scheme shell. SUnet makes extensive use of
Scsh's facilities for multi-threaded systems programming on Unix.
Scsh's facilities for multi-threaded systems programming und Unix.
SUnet includes the following components:
* The SUnet Web server
This is a highly configurable HTTP 1.0 server in Scheme.
The server is accompanied some libraries which may also
This is a highly configurable HTTP 1.1 server in Scheme.
The server is accompanied by some libraries which may also
be used separately:
* URI and URL parsers and unparsers
* an URL parser and unparser
* a library for writing CGI scripts in Scheme
* server extensions for interfacing to CGI scripts
* server extensions for uploading Scheme code
* simple structured HTML output library
* a simple structured HTML output library
The server also ships with a sophisticated interface for writing
server-side Web applications called "SUrflets".
@ -66,8 +66,7 @@ Installation
============
Starting with version 2.1 SUnet conforms to the packaging proposal for
scsh by Michel Schinz and needs Michel's installation library to
install properly. For more information, please see:
scsh by Michel Schinz. Please see:
<http://lamp.epfl.ch/~schinz/scsh_packages/>
@ -107,12 +106,11 @@ Support
Please direct questions, comments, answers about SUnet to the regular
scsh mailing list at
scsh-users@scsh.net
scsh@zurich.ai.mit.edu
Relax, hack, and enjoy!
Dr. S.
Dr. S.
Michael Sperber
Martin Gasbichler
Eric Marsden
Andreas Bernauer
Andreas Bernauer

32
doc/latex/decls.tex
View File

@ -222,12 +222,6 @@
{\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.
@ -291,21 +285,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{alltt}\small\normalem}
{\end{alltt}}
{\ULforem\begin{proglist}\begin{alltt}\small\normalem}
{\end{alltt}\end{proglist}}
\newenvironment{reflisting}[1]
{\ULforem[\refinlisting{#1}]\begin{alltt}\small\normalem}
{\end{alltt}}
{\ULforem\begin{proglist}[\refinlisting{#1}]\begin{alltt}\small\normalem}
{\end{alltt}\end{proglist}}
\newcommand{\contatlisting}[1]{%
{\normalfont\textit{$<$continued in listing~\ref{#1}\/$>$}}}
@ -316,6 +310,14 @@
\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{ftp-set-type!}{connection ftp-type}{undefined}
\defunx{set-ftp-type!}{connection ftp-type}{undefined}
\begin{desc}
This change the transfer mode for future file transfers. The
transfer mode is specfified by \var{ftp-type} which can be created

109
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-ips?}{resolve-ip? [options]}{options}
\defun{with-resolve-ip?}{resolve-ip? [options]}{options}
\begin{desc}
This specifies whether the server writes the domain names rather
than numerical IPs to the output log it produces. Defaults to
@ -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 socket connected
for each line. \ex{Request-socket} returns the the socket connected
to the client.\footnote{Request handlers should not perform I/O on the
request record's socket. Request handlers are frequently called
recursively, and doing I/O directly to the socket might bypass a
@ -204,34 +204,41 @@ constructing responses lives in the \ex{httpd-responses} structure.
\var{Location} must be URI-encoded and begin with a slash.
\end{desc}
\defun{make-error-response}{status-code request [message] extras \ldots}{response}
\defun{make-error-response}{status-code request extra \ldots}{response}
\begin{desc}
This is a helper procedure for constructing error responses.
\var{code} is status code of the response (see below). \var{Request}
is the request that led to the error. \var{Message} is an optional
string containing an error message written in HTML, and \var{extras}
are further optional arguments containing further message lines to
\ex{Make-error-response} returns a response value the body of which
is a web page explaining the error at hand.
\var{status-code} is the status code of the response (see below).
\var{request}
is the request that led to the error. \var{extra} are the further
arguments required for this specific \var{status-code} and
optionally further information-bits (preferably strings in HTML) to
be added to the web page that's generated.
\ex{Make-error-response} constructs a response value which generates
a web page containg a short explanatory message for the error at hand.
\end{desc}
\begin{table}[htb]
\centering
\begin{tabular}{|l|l|l|}
\hline
continue & 100 & Continue\\\hline
switch-protocol & 101 & Switching Protocol\\\hline
ok & 200 & OK\\\hline
created & 201 & Created\\\hline
accepted & 202 & Accepted\\\hline
prov-info & 203 & Provisional Information\\\hline
non-author-info & 203 & Non-Authoritative Information\\\hline
no-content & 204 & No Content\\\hline
reset-content & 205 & Reset Content\\\hline
partial-content & 206 & Partial Content\\\hline
mult-choice & 300 & Multiple Choices\\\hline
moved-perm & 301 & Moved Permanently\\\hline
moved-temp & 302 & Moved Temporarily\\\hline
method & 303 & Method (obsolete)\\\hline
found & 302 & Found\\\hline
see-other & 303 & See other\\\hline
not-mod & 304 & Not Modified\\\hline
use-proxy & 305 & Use Proxy\\\hline
temp-redirect & 307 & Temporary Redirect\\\hline
bad-request & 400 & Bad Request\\\hline
unauthorized & 401 & Unauthorized\\\hline
@ -239,16 +246,26 @@ constructing responses lives in the \ex{httpd-responses} structure.
forbidden & 403 & Forbidden\\\hline
not-found & 404 & Not Found\\\hline
method-not-allowed & 405 & Method Not Allowed\\\hline
none-acceptable & 406 & None Acceptable\\\hline
proxy-auth-required & 407 & Proxy Authentication Required\\\hline
not-acceptable & 406 & Not Acceptable\\\hline
proxy-auth-required &407 & Proxy Authentication Required\\\hline
timeout & 408 & Request Timeout\\\hline
conflict & 409 & Conflict\\\hline
gone & 410 & Gone\\\hline
length-required & 411 & Length Required\\\hline
precon-failed & 412 & Precondition Failed\\\hline
req-ent-too-large & 413 & Request Entity Too Large\\\hline
req-uri-too-large & 414 & Request URI Too Large\\\hline
unsupp-media-type & 415 & Unsupported Media Type\\\hline
req-range-not-sat & 416 & Requested Range Not Satisfiable\\\hline
expectation-failed & 417 & Expectation Failed\\\hline
internal-error & 500 & Internal Server Error\\\hline
not-implemented & 501 & Not Implemented\\\hline
bad-gateway & 502 & Bad Gateway\\\hline
service-unavailable & 503 & Service Unavailable\\\hline
service-unavailable &503 & Service Unavailable\\\hline
gateway-timeout & 504 & Gateway Timeout\\\hline
version-not-supp & 505 & HTTP Version Not Supported\\\hline
\end{tabular}
\caption{HTTP status codes}
\label{tab:status-code-names}
@ -334,8 +351,8 @@ exported by the \ex{httpd\=basic\=handlers} structure:
\defvar{null-request-handler}{request-handler}
\begin{desc}
This request handler always generated a \ex{not-found} error
response, no patter what the request is.
This request handler always generates a \ex{not-found} error
response, no matter what the request is.
\end{desc}
\defun{make-predicate-handler}{predicate handler
@ -680,62 +697,6 @@ 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 \textit{SUrflets}.
server-side Web applications called "SUrflets".
\item[The SUnet ftp server]
This is a complete anonymous ftp server in Scheme.
@ -82,44 +82,21 @@ 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.6 or later of \urlhd{http://www.scsh.net/}{scsh}{scsh from
version 0.6.4 or later of \urlhd{http://www.scsh.net/}{scsh}{scsh from
\url{http://www.scsh.net/}}.
\section{How to install SUnet}
Starting with version 2.1 SUnet conforms to the packaging proposal for
scsh by Michel Schinz and needs Michel's installation library to
install properly. For more information, please see
\url{http://lamp.epfl.ch/~schinz/scsh_packages/}.
In short, this means that you can install SUnet by unpacking the SUnet
tarball and issuing the following command in the created directory:
\begin{verbatim}
scsh-install-pkg --prefix /path/to/your/package/root
\end{verbatim}
See the file INSTALL for the generic installation instructions for
scsh packages.
You need to install version 4.9 of the SSAX package to use SUnet. SSAX
is available from \url{http://lamp.epfl.ch/~schinz/scsh_packages/}.
\section{How to use the packages}
%
After installation, you can use the \verb+-lel+ command-line option to
load the package definitions. If you installed SUnet including
SUrflets (the default), you need to load SSAX as well:
Untar the SUnet distribution somewhere. Fire up scsh and load the
SUnet \texttt{packages.scm} file into the configuration package.
After that, all structures defined by SUnet are available:
%
\begin{alltt}
atari-2600[72] scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm
Welcome to scsh 0.6.6 (King Conan)
atari-2600[72] scsh
Welcome to scsh 0.6.4 (...)
Type ,? for help.
\end{alltt}
%
Now, all structures defined by SUnet and SSAX are available:
%
\begin{alltt}
> ,config ,load packages.scm
modules.scm
> ,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{October 2004}
\date{April 2004}
\mainmatter
\maketitle

1679
doc/latex/surfletapi.tex
View File

File diff suppressed because it is too large Load Diff

289
doc/latex/surflethowto.tex
View File

@ -20,31 +20,28 @@
%%tableofcontents
%%sloppy
\section{Howto}
\label{sec:surflethowto}
\section{Introduction}
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. See section \ref{sec:surflet-api} for the (technical) API
description.
surflets. The \surflet API will be described in the SUnet
documentation eventually.
\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 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:
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:
\begin{enumerate}
\item \surflets have an automatic program flow control like any
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.
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.
\item \surflets come along with a library for robust user
interaction. \surflets represent interaction elements of the web page
@ -58,7 +55,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}.
\subsection{How to run the SUnet webserver that handles \surflets}
\section{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
@ -125,7 +122,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: 8080
port: 8008
log-file-name: /tmp/httpd.log
a maximum of 5 simultaneous requests, syslogging activated,
and home-dir-handler (public_html) activated.
@ -134,7 +131,7 @@ Going to run SUrflet server with:
\end{alltt}
This means the server is up and running. Try to connect to
\url{http://localhost:8080} with your browser and you will see the
\url{http://localhost:8008} 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.
@ -144,8 +141,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, you will see
an error message similar to this one:
If the port the \surflet server tries to use is occupied use, you will
see an error message similar to this one:
\begin{alltt}
Error: 98
@ -153,7 +150,7 @@ Error: 98
#{Procedure 11701 (\%bind in scsh-level-0)}
4
2
(0 . 8080)
(0 . 8008)
\end{alltt}
In this case, pass another port number to the script, \eg 8000:
@ -163,12 +160,12 @@ The \typew{--help} option will show you more parameters that you can
adjust, but you won't need them for this howto.
\subsection{How to send web pages}
\section{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.
\subsubsection{My first \surflet}
\subsection{My first \surflet}
\label{sec:first-surflet}
Traditionally, your first program in any programming language prints
@ -244,7 +241,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.
just sends the HTML page and does not return and
\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
@ -255,35 +252,38 @@ 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 lists, too. Here are some
HTML tag. The contents can be other SXML list, too. Here are some
examples of SXML lists and how they translate to HTML:
%\newcommand{\htmltag}[1]{$\mathtt{<}$#1$\mathtt{>}$}
\begin{tabular}{ll}
SXML: & \verb|'(p "A paragraph.")}| \\
HTML: & \verb|<p>A paragraph.\htmltag{/p}}|\\
\newcommand{\htmltag}[1]{$\mathtt{<}$#1$\mathtt{>}$}
\begin{tabbing}
HTML: \medskip\=\kill
SXML: \> \texttt{'(p "A paragraph.")} \\
HTML: \> \texttt{\htmltag{p}A paragraph.\htmltag{/p}}\\
\\
SXML: & \verb|'(p "A paragraph." (br) "With break line.")}| \\
HTML: & \verb|<p>A paragraph.<br>With break line.</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 "Nested" (p "paragraphs"))}|\\
HTML: & \verb|<p>Nested<p>paragraphs</p></p>}|\\
\end{tabular}
SXML: \> \texttt{'(p "Nested" (p "paragraphs"))}\\
HTML: \> \texttt{\htmltag{p}Nested\htmltag{p}paragraphs\htmltag{/p}\htmltag{/p}}\\
\end{tabbing}
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{tabular}{ll}
SXML: & \verb|'(a (@ (href "attr.html")) "Attributed HTML tags.")|\\
HTML: & \verb|<a href="attr.html">Attributed HTML tags.</a>|\\
\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}}\\
\\
SXML: & \verb|'(a (@ (href "attr2.html") (target "\_blank")) "2
attributes.")}| \\
HTML: & \verb|<a href="attr2.html" target="\_blank">2 attributes.</a>}|
\end{tabular}
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}
As you see from the \surflet example, \name{send-html/finish} expects
SXML as an argument. In the example, the SXML translates to the
as an argument SXML. 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.
\subsubsection{Dynamic content}
\subsection{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 a list whose
feature of Scheme to create a ``dynamic'' list, \ie 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.
\subsubsection{Several web pages in a row}
\subsection{Several web pages in a row}
The previous example \surflets only showed one page and finished
afterwards. Here, we want to present two web pages in a row. We use
afterwards. Here, we want to present to web pages in a row. We use
the previously mentioned function \name{send-html/suspend}, which
suspends after it has sent the page and continues when the user
suspends after it has send 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 next statement after the call to \name{send-html/suspend} is
the 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
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.}
session, you can use \name{set-session-data!} and
\name{get-session-data}. See the API documentation for further
information.}
\subsubsection{Begin and end of sessions}
\subsection{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 care
of the session automatically as described in the previous paragraph.
reason is, as mentioned before, that the \surflet handler takes 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.
\subsubsection{Abbreviations in SXML}
\subsection{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.
\subsection{How to write web forms}
\section{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.
\subsubsection{Simple web forms}
\subsection{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
soon see the advantages of this approach.
can pass to functions, receive them as return values, etc. You'll see
soon 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.
Thus, the scheme for user interaction is about the following:
The scheme for user interaction is thus 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 in section \ref{sec:surflet-api}.
found in the API.
\subsubsection{Return types other than strings}
\subsection{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 an input field that accepts only
come with a number input field, \ie a 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 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).
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).
\subsubsection{Sending error messages}
\subsection{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 terminate the current session} as your \surflet obviously
\emph{and terminating 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}
\codemph{ surflets/error}
\codemph{ handle-fatal-error
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 }
\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)))) }
\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))))}
(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 text message to explain the
occured. The last argument is a free message text to explain the
cause of the error to the user.
While in the original \surflet the user will still see the resulting
@ -783,18 +783,17 @@ 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.
\subsubsection{Your own input fields}
\subsection{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 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.
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.
Let's have a look at an \surflet that uses its own input field. The
``input field'', called nibble input field, consists of four check
``input field'', called nibble input field, consists of eight 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
@ -915,7 +914,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, zero is
\name{input-field-value} can find it. If it can't find it, a zero is
added instead. The value of our nibble input field is the resulting
sum.
@ -924,7 +923,7 @@ again. We create, use and evaluate the nibble input field as we do
with every other input field.
\subsection{Program flow control}
\section{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
@ -935,7 +934,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.
\subsubsection{Dispatching to more than one successor web page}
\subsection{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}
@ -1022,8 +1021,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 clicked on the
link we have named \name{german} in our \surflet,
has selected ``German'' as her preferred language and thus 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.
@ -1038,7 +1037,7 @@ shortly. Of course, it is your choice if you want to use
\name{case-returned-via} or explicitly \name{returned-via}.
\subsubsection{Annotated dispatching}
\subsection{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
@ -1064,11 +1063,11 @@ We modify the previous code example slightly to this \surflet
(body
(h2 "Select your language:")
(ul
(li (url ,\codemph{(language k-url }
\codemph{ "Hello, how are you?")}
(li (url ,\codemph{(language k-url
"Hello, how are you?")}
"English")
(li (url ,\codemph{(language k-url }
\codemph{ "Hallo, wie geht es Ihnen?")}
(li (url ,\codemph{(language k-url
"Hallo, wie geht es Ihnen?")}
"Deutsch")))))))))
(bindings (get-bindings req)))
(case-returned-via bindings
@ -1128,14 +1127,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).
\subsubsection{Callbacks}
\subsection{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
pages and you don't have to use \name{send-html/suspend}.
page and thus 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
@ -1183,8 +1182,7 @@ 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, in which case you have to use
\name{send-html/suspend}.
the callback method, so 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
@ -1205,7 +1203,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}
@ -1214,19 +1212,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.
\subsection{Data management}
\section{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
user's login, and data that is global to each instance of a \surflet,
users 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 session of a \surflet, while changes to global data is visible
to every session of a \surflet.
each instance of a \surflet, while changes to global data is visible
to every instance 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
these data types in a regular Scheme program.
this 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
@ -1240,7 +1238,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 data.
reified continuations reifies also the values of all (local) 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
@ -1343,13 +1341,13 @@ endless states of the \surflet.
\name{cancel} shows the final page with the amount of clicks
performed.
\subsection{My own SXML}
\section{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.
\subsubsection{Terms and theoretical background}
\subsection{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.
@ -1357,48 +1355,53 @@ 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 printed into an HTML string. This is done by the
is translated into an HTML string. This is done by the
\textit{printer}. The intermediate form looks very much like SXML,
but contains only \textit{atoms} or, recursively, list of atoms.
but contains only atoms or, recursively, list of \textit{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. 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
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
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 takes the SXML tree and a list of conversion rules as
The translator gets 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 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.
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.
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.
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.
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 (\&).
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 (\&).
\subsubsection{Outlook}
\section{Outlook}
More to come soon about \surflets consisting of different parts and
individual SXML.

9
doc/latex/surflets.tex
View File

@ -3,12 +3,9 @@
\newcommand{\typew}[1]{\texttt{#1}}
The \surflet server enables you to write server side scripted web
programs in Scheme.
%Currently, there is only the howto available.
%The complete API is supposed to come soon.
There are lots of example files in
\typew{scheme/httpd/surflet/webserver/root/surflets} from which you
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
can copy freely.
\input{surflethowto}
\input{surfletapi}

176
doc/latex/uri.tex
View File

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

150
doc/latex/url.tex
View File

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

4
pkg-def.scm
View File

@ -5,6 +5,10 @@
(let ((surflets? (get-option-value 'with-surflets)))
(install-directory-contents "scheme" 'scheme)
(install-directory "web-server" 'misc-shared)
(install-file "start-web-server" 'misc-shared "web-server")
(install-file "start-extended-web-server" 'misc-shared "web-server")
(if surflets?
(install-file "start-surflet-server" 'misc-shared "web-server"))
(install-directory-contents "doc" 'doc)
(let ((doc-dir (get-directory 'doc #t))

82
scheme/dnsd/README
View File

@ -1,82 +0,0 @@
***********************
*** README for DNSD ***
***********************
Copyright (c) 2005/2006 by Norbert Freudemann
<nofreude@informatik.uni-tuebingen.de>
For copyright information, see the file COPYING which comes with
the distribution.
RUNNING THE NAMESERVER:
-----------------------
1) Install SCSH, SUnet and SUnterlib
---------------------------------
For instructions see www.scsh.net
2) The configuration
-----------------
There is a folder etc/ containing the files
dnsd-options.scm
dnsd-zones.scm
dnsd-pre.scm
dnsd-post.scm
and some additional masterfile-examples.
You can copy this files to a directory of your liking
or simply use the given path (from the SUnet-installation).
Either way, the path will be called <path-to-options>.
You can customize the files:
2.1) dnsd-options.scm
Options for DNSD. Open the file for documentation.
2.2) dnsd-zones.scm
Add/remove zones to DNSD. Documentation is included in the file.
2.3) dnsd-pre.scm / dnsd-post.scm
You can customize the behaviour of query-processing within these
two files.
3) Run SCSH:
---------
Load the CML-API from SUnterlib and SUnet.
> scsh -lel cml/load.scm -lel sunet/load.scm
4) SCSH-REPL:
----------
>,in dnsd
Start DNSD with
dnsd> (dnsd-start)
if the current working-directory is <path-to-options> or else use
dnsd> (dnsd-start <path-to-options>)
5) While running DNSD:
-------------------
* Reload the file dnsd-options.scm with the POSIX-signal USR1.
* Reload the file dnsd-zones.scm with the POSIX-signal USR2.

170
scheme/dnsd/cache.scm
View File

@ -1,170 +0,0 @@
; ----------------------------
; --- Query/Response-Cache ---
; ----------------------------
; Cache for dnsd.scm
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Revised version of the cache implementation seen in dns.scm.
; The cache stores data that was received during a recursive lookup.
; The access-key of the cache consists of a question-name/class/type, the
; data is a list of answers/additionals/authority.
; It uses r/w-lock to avoid multiple simultaneous writes.
; Cache-Interface:
; -----------------
; (dnsd-cache-clear!) - Removes the whole data.
; (dnsd-cache-clean!) - Removes expired data.
; (dnsd-cache-lookup? msg) - Searches for a cached reply.
; (dnsd-cache-update! msg) - Updates the data to include the given msg.
; (dnsd-cache-pretty-print) - Prints the cache.
;; Cache:
;; ------
(define-record-type dnsd-cache :dnsd-cache
(make-dnsd-cache data lock)
dnsd-cache?
(data get-dnsd-cache-data) ; cache-data-record-type
(lock get-dnsd-cache-lock)) ; r/w-lock
(define-record-type cache-data :cache-data
(make-cache-data answer expires)
cache?
(answer cache-data-answer) ; an answer as needed by lookup-query
(expires cache-data-expires)) ; expiration time of the data (+ ttl (time))
;; Create the cache:
(define *dnsd-cache* (make-dnsd-cache (make-string-table) (make-r/w-lock)))
;; Search for the shortest TTL in the message:
;; TYPE: message -> number or #f
(define (find-shortest-ttl msg)
(let loop ((msg msg))
(cond
((dns-message? msg) (loop (dns-message-reply msg)))
((message? msg) (fold-right
(lambda (e m)
(let ((ttl (resource-record-ttl e)))
(if m
(if (<= m ttl) m ttl)
ttl)))
#f
(append (message-answers msg)
(message-nameservers msg)
(message-additionals msg)))))))
;; Make a cache-key from the message:
;; TYPE: message -> key-string
(define (make-cache-key msg)
(let ((question (car (message-questions msg))))
(format #f "~a;~a;~a" (question-name question)
(message-type-name (question-type question))
(message-class-name (question-class question)))))
;; Reset the cache:
(define (dnsd-cache-clear!)
(with-r/W-lock
(get-dnsd-cache-lock *dnsd-cache*)
(lambda ()
(set! *dnsd-cache*
(make-dnsd-cache (make-string-table)
(get-dnsd-cache-lock *dnsd-cache*))))))
;; Remove expired data from the cache:
(define (dnsd-cache-clean!)
(with-r/W-lock
(get-dnsd-cache-lock *dnsd-cache*)
(lambda ()
(let ((time (time))
(table (get-dnsd-cache-data *dnsd-cache*)))
(table-walk (lambda (k e)
(if (< time (cache-data-expires e))
#t
(table-set! table k #f)))
table)))))
; Look for data in the cache. If the found answer is expired return
; #f and remove the answer from the cache.
; TYPE: message -> '(l-of-answ l-of-auth l-of-addi boolean) or #f
(define (dnsd-cache-lookup? msg)
(let ((lock (get-dnsd-cache-lock *dnsd-cache*)))
(obtain-R/w-lock lock)
(let* ((data (get-dnsd-cache-data *dnsd-cache*))
(key (make-cache-key msg))
(cdata (table-ref data key)))
(if cdata
(if (< (time) (cache-data-expires cdata))
(let ((res (cache-data-answer cdata)))
(release-R/w-lock lock)
res)
(begin
(release-R/w-lock lock)
(obtain-r/W-lock lock)
(table-set! data key #f)
(release-r/W-lock lock)
#f))
(begin
(release-R/w-lock lock)
#f)))))
;; Add the answer-sections (ansers/authority/additionals) and the authoritative
;; flag of a message to the cache:
;; TYPE: message -> unspecific
(define (dnsd-cache-update! msg)
(with-r/W-lock
(get-dnsd-cache-lock *dnsd-cache*)
(lambda ()
(let ((shortest-ttl (find-shortest-ttl msg)))
(if (> shortest-ttl 0)
(table-set!
(get-dnsd-cache-data *dnsd-cache*)
(make-cache-key msg)
(make-cache-data
(list (message-answers msg)
(message-nameservers msg)
(message-additionals msg)
(header-flags (message-header msg))) ; authoritative?
(+ (time) shortest-ttl)))
#f)))))
;; Display the cache:
(define (dnsd-cache-pretty-print)
(with-R/w-lock
(get-dnsd-cache-lock *dnsd-cache*)
(lambda ()
(let ((data (get-dnsd-cache-data *dnsd-cache*)))
(display "DNSD-CACHE:\n")
(display "-----------\n")
(table-walk
(lambda (k e)
(let ((cache-data (cache-data-answer e)))
(display "\n*Question: ")
(display k)(newline)
(display " ---------\n")
(display " Expires in: ")
(display (- (cache-data-expires e) (time)))
(display " seconds.\n")
(display " \n Answer-Section:\n\n")
(map (lambda (x) (pretty-print-dns-message x)) (car cache-data))
(display " \n Authority-Section:\n\n")
(map (lambda (y) (pretty-print-dns-message y)) (cadr cache-data))
(display " \n Additionals-Section:\n\n")
(map (lambda (z) (pretty-print-dns-message z)) (caddr cache-data))))
data)))))

674
scheme/dnsd/database.scm
View File

@ -1,674 +0,0 @@
;; ---------------------
;; --- dnsd-database ---
;; ---------------------
; A simple database for dnsd.scm
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Naming-Scheme:
; --------------
; dbi- == No locks (should not be exported)
; db- == With locks
; Lock-Safe Database-Interface:
; -----------------------------
; (db-clear-database)
; (db-clear-zone name class)
; (db-update-zone zone-list)
; (db-get-zone name class)
; (db-get-zone-for-axfr name class)
; (db-get-zone-soa-rr name class)
; (db-pretty-print)
; Query/Database-Interface
; ------------------------
; (db-lookup-rec qname class type)
; Database Structure:
; -------------------
; db-class-table: hash-table to db-zones
; |
; |-->db-zones-table: hash-table to db-zone
; |
; |-->db-zone: hash-table to db-rr
; |
; |-->db-rr-table: hash-table to lists of resource-records
; of a given message-type
;; Some stuff:
;; -----------
;; Should be a dnsd-option?
(define *debug-info* #t)
;; Make a key for the database:
;; TYPE: string -> string
(define (make-key-name name)
(let ((last-char (string-ref name (- (string-length name) 1))))
(string-downcase (if (not (char=? #\. last-char))
(string-append name ".")
name))))
;; Compare the first string with the rear of the second string.
;; TYPE: string x string -> boolean
(define (string-ci-zone-name=? zone name)
(let ((l1 (string-length zone))
(l2 (string-length name)))
(if (<= l1 l2) (string-ci=? zone (substring name (- l2 l1) l2)) #f)))
;; Search a list of resource-records for the soa-rr:
;; TYPE: list-of-rrs -> soa-rr or #f
(define (maybe-get-soa-rr l)
(let loop ((l l))
(if (null? l)
#f
(let ((e (car l)))
(if (resource-record-data-soa?
(resource-record-data e))
e
(loop (cdr l)))))))
;; Get the name of a zone from a soa-rr within a zone-list:
;; TYPE: list-of-rrs -> zone-name or #f
(define (maybe-get-soa-rr-name l)
(and-let* ((soa-rr (maybe-get-soa-rr l)))
(resource-record-name soa-rr)))
;; TYPE : list-or-rrs -> list-of-rrs
(define (get-zone-list-w/o-soa l)
(fold-right
(lambda (e l)
(if (resource-record-data-soa? (resource-record-data e)) l (cons e l)))
'() l))
;; TODO: Do this different...
(define display-debug
(lambda args
(if *debug-info*
(begin
(display "dnsd: ")
(map (lambda (e) (display e) (display " ")) args)
(newline))
#f)))
;; Duplicate a resource-record: (Needed for wildcard-replies)
(define (duplicate-rr name rr)
(make-resource-record name
(resource-record-type rr)
(resource-record-class rr)
(resource-record-ttl rr)
(resource-record-data rr)))
; ---------------------------
; --- Database definition ---
; ---------------------------
; Record-types:
; -------------
; db-rr-table stores the resource-records of ONE domain-name.
; hash-table is a symbol-table with 'message-type' as keys
; and a list of resource-record of the key-message-type as data.
; glue-data stores the information (as boolean) if the given domain-name
; is for glue-data or official.
(define-record-type db-rr-table :db-rr-table
(really-make-db-rr-table hash-table glue-data)
db-rr-table?
(hash-table db-rr-table-hash-table)
(glue-data db-rr-table-glue-data? set-db-rr-table-glue-data?!))
(define (make-db-rr-table) (really-make-db-rr-table (make-symbol-table) #f))
; db-zone stores data (in form of db-rr-tables) for an entire zone
; as given by e.g. a masterfile
; hash-table a string-table. Keys are the domain-names of the zone
; to link to db-rr-tables.
; name the name of the zone.
; soa-rr for easy-access :-)
(define-record-type db-zone :db-zone
(really-make-db-zone hash-table name soa-rr)
db-zone?
(hash-table db-zone-table)
(name db-zone-name)
(soa-rr get-db-zone-soa-rr))
(define (make-db-zone name soa-rr)
(let ((primary-name (resource-record-data-soa-mname
(resource-record-data soa-rr))))
(really-make-db-zone (make-string-table) name soa-rr)))
; db-zones-table stores all zones of a given message-class
; hash-table key is the zone-name.
(define-record-type db-zones-table :db-zones-table
(really-make-db-zones-table hash-table)
db-zones-table?
(hash-table db-zones-table-hash-table))
(define (make-db-zones-table) (really-make-db-zones-table (make-string-table)))
; db-class-table entry-point for the db.
; hash-table key is the message-class (e.g. in) data are db-zones-tables
; r/w-lock lock for exclusive-write-access.
(define-record-type db-class-table :db-class-table
(really-make-db-class-table hash-table r/w-lock)
db-class-table?
(hash-table db-class-table-hash-table set-db-class-table-hash-table!)
(r/w-lock db-class-table-r/w-lock))
(define *database* (really-make-db-class-table (make-symbol-table)
(make-r/w-lock)))
; Predicates:
; -----------
; Check if there is data for a given message-class:
; TYPE: message-class -> boolean
(define (dbi-class? class)
(if (table-ref (db-class-table-hash-table *database*)
(message-class-name class))
#t #f))
;; Modifiers:
;; ----------
;; Delete the whole data in the database:
(define (db-clear-database)
(with-r/W-lock
(db-class-table-r/w-lock *database*)
(lambda ()
(set-db-class-table-hash-table! *database* (make-symbol-table)))))
;; Delete a zone (if present) with name 'name' from the database:
;; TYPE: string x message-class -> boolean
(define (db-clear-zone name class)
(with-r/W-lock
(db-class-table-r/w-lock *database*)
(lambda ()
(and-let* ((whatever (dbi-class? class))
(class-table (db-class-table-hash-table *database*))
(zones-type (table-ref class-table (message-class-name class)))
(zones-table (db-zones-table-hash-table zones-type))
(key-name (make-key-name name))
(whatever (table-ref zones-table key-name)))
(table-set! zones-table key-name #f)))))
;; Stuff for db-add-zone:
;; Add a new class (if not already present) to the database:
;; TYPE: message-class -> unspecific
(define (dbi-maybe-add-class class)
(if (not (dbi-class? class))
(table-set! (db-class-table-hash-table *database*)
(message-class-name class)
(make-db-zones-table))))
;; --- Detection of Zone-Rules ---
;; Detect and mark glue data (domains with NS and all of their subdomains)
;; Give a warning, if the zone-tree is broken
;; TYPE: db-def-table x string -> unspecific
(define (dbi-mark-glue-in-zone def-table zone-name)
(let ((tree (db-zone-table def-table)))
(table-walk
(lambda (key element)
(if (table-ref (db-rr-table-hash-table element)
(message-type-name (message-type a)))
(let loop ((name key))
(if (string-ci=? name zone-name)
#t
(let ((zone-entry (table-ref tree name)))
(if zone-entry
(if (table-ref (db-rr-table-hash-table zone-entry)
(message-type-name (message-type ns)))
(set-db-rr-table-glue-data?! element #t)
(loop (cut-name name)))
;; Be tolerant if the domain tree is broken...
(begin
(dnsd-log (syslog-level info)
"Warning (re)loading zone ~S. Broken tree: Domain ~S is missing!"
zone-name name)
(loop (cut-name name)))))))
#t))
tree)))
;; Ensures the min. TTL from the soa-rr of the zone. Has to be called
;; after dbi-mark-glue-in-zone!
;; TYPE: db-def-table x soa-rr -> unspecific
(define (dbi-ensure-min-ttl def-table soa-rr)
(let ((min-ttl (resource-record-data-soa-minimum
(resource-record-data soa-rr))))
(table-walk
(lambda (key element)
(if (not (db-rr-table-glue-data? element))
(table-walk
(lambda (tkey telement)
(table-set! (db-rr-table-hash-table element)
tkey
(map (lambda (e)
(let ((rr-ttl (resource-record-ttl e)))
(make-resource-record
(resource-record-name e)
(resource-record-type e)
(resource-record-class e)
(if (< rr-ttl min-ttl)
min-ttl rr-ttl)
(resource-record-data e))))
telement)))
(db-rr-table-hash-table element))))
(db-zone-table def-table))))
;; Give a warning, if a Zone with a CNAME-RR contains other stuff...
;; TYPE: db-def-table -> unspecific
(define (dbi-cname-warning def-table zone-name)
(table-walk
(lambda (key element)
(let ((rr-table (db-rr-table-hash-table element))
(cname (message-type-name (message-type cname))))
(if (table-ref rr-table cname)
(table-walk
(lambda (k e)
(if (not (eq? k cname))
(dnsd-log (syslog-level info)
"Warning (re)loading zone ~S. Domain ~S contains a CNAME-RR and other RRs at the same time."
zone-name key)
(if (not (= 1 (length e)))
(dnsd-log (syslog-level info)
"Warning (re)loading zone ~S. Domain ~S contains 2 or more CNAME-RRs!"
zone-name key))))
rr-table))))
(db-zone-table def-table)))
;; This functions have to be called in the given order:
;; TYPE: db-def-table x string x soa-rr -> unspecific
(define (dbi-set-zone-requirements def-table zone-name soa-rr)
(dbi-mark-glue-in-zone def-table zone-name)
(dbi-ensure-min-ttl def-table soa-rr)
(dbi-cname-warning def-table zone-name))
;; Adds a list of resource-records to a zone-definition-table:
(define (dbi-add-zone-list def-table rr-list)
(let ((tree (db-zone-table def-table)))
(for-each
(lambda (e)
(let* ((domain-key (make-key-name (resource-record-name e)))
(type-key (message-type-name (resource-record-type e)))
(rr-type (table-ref tree domain-key)))
;; Create & link a new rr-table for the first entry of the rr-type:
(if (not (db-rr-table? rr-type))
(begin (set! rr-type (make-db-rr-table))
(table-set! tree domain-key rr-type)))
(let* ((rr-table (db-rr-table-hash-table rr-type))
(entry (table-ref rr-table type-key)))
(if entry
(table-set! rr-table type-key (cons e entry))
(table-set! rr-table type-key (cons e '()))))))
rr-list)))
;; Adds a zone to the database which is given as a list of resource-records.
;; Notes: * db-add-zone doesn't overwrite existing zones.
;; * Just for internal use.
;; TYPE: list-of-rrs -> boolean
(define (db-add-zone zone-list)
(with-r/W-lock
(db-class-table-r/w-lock *database*)
(lambda ()
(and-let* ((soa-rr (maybe-get-soa-rr zone-list))
(zone-name (resource-record-name soa-rr))
(zone-key (make-key-name zone-name))
(zone-class (resource-record-class soa-rr)))
;; Add another class to the database?
(dbi-maybe-add-class zone-class)
;; Get the zone-stuff to insert the zone into together:
(let* ((zone-table (db-zones-table-hash-table
(table-ref (db-class-table-hash-table *database*)
(message-class-name zone-class)))))
;; Don't overwrite an existing zone
(if (table-ref zone-table zone-key) #f
;; Add the zone to the db & ensure data integrity:
(let* ((zone-dtable (make-db-zone zone-key soa-rr)))
(table-set! zone-table zone-key zone-dtable)
(dbi-add-zone-list zone-dtable zone-list)
(dbi-set-zone-requirements zone-dtable zone-name soa-rr))))))))
;; Update a zone if the serial of the new soa isn't the same or less.
;; TYPE: list-of-rrs -> boolean
(define (db-update-zone zone-list)
(and-let* ((new-soa-rr (maybe-get-soa-rr zone-list))
(new-serial (resource-record-data-soa-serial
(resource-record-data new-soa-rr)))
(zone-name (make-key-name (resource-record-name new-soa-rr)))
(zone-class (resource-record-class new-soa-rr)))
(let ((old-soa-rr (db-get-zone-soa-rr zone-name zone-class)))
(cond
((or (not old-soa-rr)
(and old-soa-rr
(> new-serial (resource-record-data-soa-serial
(resource-record-data old-soa-rr)))))
(db-clear-zone zone-name zone-class)
(db-add-zone zone-list))
((= new-serial (resource-record-data-soa-serial
(resource-record-data old-soa-rr)))
#t) ;; !!! If the serial hasn't changed it's considered successfull.
(else #f)))))
; Get all resource records for a zone.
; TYPE: string x message-class -> list-of-rrs or #f
(define (db-get-zone name class)
(with-R/w-lock
(db-class-table-r/w-lock *database*)
(lambda ()
(and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
(message-class-name class)))
(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
(make-key-name name)))
(zone-tree-tree (db-zone-table the-zone-type))
(res-list '()))
(table-walk
(lambda (k e)
(if e
(table-walk (lambda (k1 e1)
(set! res-list (append e1 res-list)))
(db-rr-table-hash-table e))))
zone-tree-tree)
res-list))))
; ; Get the timestamp for a zone.
; ; TYPE: string x message-class -> number or #f
; (define (db-get-zone-timestamp name class)
; (with-R/w-lock
; (db-class-table-r/w-lock *database*)
; (lambda ()
; (and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
; (message-class-name class)))
; (the-zone-type (table-ref (db-zones-table-hash-table zone-type)
; (make-key-name name))))
; (get-db-zone-timestamp the-zone-type)))))
;; Get the soa-rr of a zone.
;; TYPE: string x message-class -> soa-rr or #f
(define (db-get-zone-soa-rr name class)
(with-R/w-lock
(db-class-table-r/w-lock *database*)
(lambda ()
(and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
(message-class-name class)))
(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
(make-key-name name))))
(get-db-zone-soa-rr the-zone-type)))))
; Get all rrs of a zone in an AXFR-ready list: '(soa-rr rr rr ... rr soa-rr)
; TYPE: string x message-class -> list-of-rrs or #f
(define (db-get-zone-for-axfr name class)
(and-let* ((zone-list (db-get-zone name class))
(soa-l (list (maybe-get-soa-rr zone-list)))
(rest-l (get-zone-list-w/o-soa zone-list)))
(append soa-l rest-l soa-l)))
;; Look for the zone in which 'name' is a subdomain or the domain of the
;; given zones. Returns the zone which is the nearest ancestor to 'name'.
;; TYPE: name x message-class -> db-zone-record-type or #f
(define (dbi-lookup-zone-for-name name class)
(and-let* ((zone-record (table-ref (db-class-table-hash-table *database*)
(message-class-name class)))
(zone-table (db-zones-table-hash-table zone-record))
(ancestors '())
(zone-key ""))
;; Look for zones who are ancestors to key:
(table-walk (lambda (k e)
(if (string-ci-zone-name=? k (make-key-name name))
(set! ancestors (cons k ancestors))))
zone-table)
(cond
((null? ancestors) #f)
((= 1 (length ancestors)) (set! zone-key (car ancestors)))
;; If more ancestors are found get the closest one:
(else (set! zone-key (fold-right (lambda (a b) (if (< (string-length a)
(string-length b))
b a))
"" ancestors))))
(table-ref zone-table zone-key)))
; Look for the entries of type 'type' in a given db-rr-table
; TYPE: db-rr-table-rec-type x message-type -> list-of-rrs
(define (dbi-lookup-rrs rr-record-type type)
(let ((rr-table (db-rr-table-hash-table rr-record-type)))
(cond
((eq? (message-type *) type) ; ... return all records.
(let ((res '())) (table-walk (lambda (k e) (set! res (cons e res)))
rr-table)
res))
(else (let ((res (table-ref rr-table (message-type-name type))))
(if res res '()))))))
;; Look for the entries of type 'type' in a given db-rr-table
;; TYPE: db-rr-table-rec-type x messag-type -> list-of-rrs or #f
(define (dbi-lookup-rrs? rr-record-type type)
(let ((res (dbi-lookup-rrs rr-record-type type)))
(if (null? res) #f res)))
;; --------------------------------
;; --- Query/Database Interface ---
;; --------------------------------
;; Requests for mailbox-related resource-records will be handled as mx requests:
;; TYPE: string x type x class ->
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
(define (db-lookup-rec qname class type)
(obtain-R/w-lock (db-class-table-r/w-lock *database*))
(receive
(anli auli adli aufl)
(dbi-lookup-rec-int qname class (if (eq? type (message-type mailb))
(message-type mx)
type) ; Mailb == mx query
'())
(release-R/w-lock (db-class-table-r/w-lock *database*))
(values anli auli adli aufl)))
;; Main part of the algorithm as described in RFC 1034. Returns found rrs and
;; a flag, indicating if the answer is authoritative.
;; The flag ist needed, because of glue-data, that could be part of the
;; response. The operand 'c-list' is used to detect and avoid cname-loops.
;; TYPE: string x type x class x c-list ->
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
(define (dbi-lookup-rec-int qname class type c-list)
(let ((zone (dbi-lookup-zone-for-name qname class)))
(if (not zone)
(values '() '() '() #f) ; no zone in db
(let ((zone-name (db-zone-name zone)))
;; loop over the labels of the name. eg. my.example. / example. / .
;; keep track of the iterations (mostly for wildcard-match support)
(let loop ((name qname) (loop-count 0))
(let ((rr-table (table-ref (db-zone-table zone)
(make-key-name name))))
(if rr-table
(cond
;; A wildcard match
((= 1 loop-count)
;; Set the name of the rrs from * to qname.
(values (map (lambda (e) (duplicate-rr qname e))
(dbi-lookup-rrs rr-table type)) '() '() #t))
;; Direct match (0) or glue-data match (>1)
((or (= 0 loop-count) (< 1 loop-count))
(cond ;c2
;; Found glue data.
((and (dbi-lookup-rrs? rr-table (message-type ns))
(not (string-ci=? name zone-name))
(not (eq? (message-type ns) type)))
(let* ((ns-rr-list (dbi-lookup-rrs?
rr-table (message-type ns)))
(res-l
(fold-right
(lambda (e l)
(receive
(anli auli adli aufl)
(dbi-lookup-rec-int
(resource-record-data-ns-name
(resource-record-data e))
class (message-type a) c-list)
(list (car l) (cadr l)
(append anli (caddr l)) #f)))
'(() () () #t) ns-rr-list)))
(values (car res-l) (append ns-rr-list (cadr res-l))
(caddr res-l) #f)))
;; Looking for correct information (direct match)
((= 0 loop-count)
(cond ;c3
;; CNAME: Causes an additional lookup
((dbi-lookup-rrs? rr-table (message-type cname))
=> (lambda (cname-rr-list)
(let ((cname-rr (car cname-rr-list)))
(if (eq? (message-type cname) type)
(values (list cname-rr) '() '() #t)
(begin
(if (fold-right
(lambda (e b)
(or (string-ci=? e name) b))
#f c-list)
(begin
;; Problem?: The loop will be send
;; as a response... .
(display-debug " Found cname-loop")
(values '() '() '() #t))
(receive
(anli auli adli aufl)
(dbi-lookup-rec-int
(resource-record-data-cname-name
(resource-record-data cname-rr))
class type (cons name c-list))
(values (append (list cname-rr) anli)
auli adli
(and aufl #t)))))))))
;; MX: Causes an additional lookup
((eq? (message-type mx) type)
(let* ((mx-rrs (dbi-lookup-rrs rr-table type))
(res-l
(fold-right
(lambda (e l)
(receive
(anli auli adli aufl)
(dbi-lookup-rec-int
(resource-record-data-mx-exchanger
(resource-record-data e))
class (message-type a) c-list)
(list (car l) (cadr l)
(append anli (caddr l))
(and #t (cadddr l)))))
'(() () () #t) mx-rrs)))
(values (append mx-rrs (car res-l)) (cadr res-l)
(caddr res-l) (and #t (cadddr res-l)))))
;; Glue-Data entries aren't authoritative:
((db-rr-table-glue-data? rr-table)
(values (dbi-lookup-rrs rr-table type) '() '() #f))
;; Found a match with no additional lookups.
(else
(values (dbi-lookup-rrs rr-table type) '() '() #t))))
;; Got a dns-name-error (RCODE=3)
(else (values '() '() '() #t)))))
;; Found no match for the current name.
(cond
((> (string-length zone-name) (string-length name))
(error "Woh, found a bug... ")) ; Just for safety...
;; Search for wildcards in the first iteration:
((= 0 loop-count)
(loop (string-append "*." (cut-name name)) 1))
(else (loop (cut-name name) (+ 1 loop-count)))))))))))
;; ------------------------------
;; --- Database pretty-print: ---
;; ------------------------------
(define (pretty-print-record-type rt)
(cond
((db-class-table? rt)
(table-walk
(lambda (k e)
(newline)
(display "DB-Class: ")
(display k)(newline)
(pretty-print-record-type e))
(db-class-table-hash-table rt)))
((db-zones-table? rt)
(table-walk
(lambda (k e)
(display " DB-Zone: ")
(display k)
(newline)
(pretty-print-record-type e))
(db-zones-table-hash-table rt)))
((db-zone? rt)
(table-walk
(lambda (k e)
(display " DB-Zone-Entries: ")
(display k)
(newline)
(pretty-print-record-type e))
(db-zone-table rt)))
((db-rr-table? rt)
(table-walk
(lambda (k e)
(display " DB-RR-Table: ")
(display k)
(newline)
(display " Glue-data: ")
(display (db-rr-table-glue-data? rt))
(newline)
(newline)
(pretty-print-record-type e))
(db-rr-table-hash-table rt)))
((list? rt)
(for-each
(lambda (e)
(pretty-print-dns-message e)
(newline))
rt))
(else (newline))))
(define (db-pretty-print)
(with-R/w-lock
(db-class-table-r/w-lock *database*)
(lambda ()
(newline)
(display "DNS-Server-Database:")(newline)
(display "--------------------")(newline)
(pretty-print-record-type *database*))))

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

@ -1,134 +0,0 @@
;; ------------------------
;; --- Database-Options ---
;; ------------------------
; Database-Options for DNS-Server based on the RFCs: 1034 / 1035
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; The format and style of the option procedures is the same as seen
; in the SUNet HTTPD & FTPD - Files
(define-record-type dnsddb-options :dnsddb-options
(really-make-dnsddb-options name class type primary? file filetype master-name master-ip)
dnsddb-options?
(name dnsddb-options-name set-dnsddb-options-name!)
(class dnsddb-options-class set-dnsddb-options-class!)
(type dnsddb-options-type set-dnsddb-options-type!)
(primary? dnsddb-options-primary? set-dnsddb-options-primary?!) ;;depreaced
(file dnsddb-options-file set-dnsddb-options-file!)
(filetype dnsddb-options-filetype set-dnsddb-options-filetype!)
(master-name dnsddb-options-master-name set-dnsddb-options-master-name!)
(master-ip dnsddb-options-master-ip set-dnsddb-options-master-ip!))
(define (make-default-dnsddb-options)
(really-make-dnsddb-options
"" ;; the name of the zone
(message-class in)
"primary" ;;
#t ;; is primary?
"" ;; a filename
"dnsd" ;; "dnsd" or "rfc"
#f ;; Has to be set by dnsd-zones.scm, e.g. "dns01.my.example."
#f)) ;; e.g. "192.168.2.1" or #f
(define (copy-dnsddb-options options)
(really-make-dnsddb-options
(dnsddb-options-name options)
(dnsddb-options-class options)
(dnsddb-options-type options)
(dnsddb-options-primary? options)
(dnsddb-options-file options)
(dnsddb-options-filetype options)
(dnsddb-options-master-name options)
(dnsddb-options-master-ip options)))
(define (make-dnsddb-options-transformer set-option!)
(lambda (new-value . stuff)
(let ((new-options (if (not (null? stuff))
(copy-dnsddb-options (car stuff))
(make-default-dnsddb-options))))
(set-option! new-options new-value)
new-options)))
(define with-name
(make-dnsddb-options-transformer set-dnsddb-options-name!))
(define with-class
(make-dnsddb-options-transformer set-dnsddb-options-class!))
(define with-type
(make-dnsddb-options-transformer set-dnsddb-options-type!))
(define with-primary?
(make-dnsddb-options-transformer set-dnsddb-options-primary?!))
(define with-file
(make-dnsddb-options-transformer set-dnsddb-options-file!))
(define with-filetype
(make-dnsddb-options-transformer set-dnsddb-options-filetype!))
(define with-master-name
(make-dnsddb-options-transformer set-dnsddb-options-master-name!))
(define with-master-ip
(make-dnsddb-options-transformer set-dnsddb-options-master-ip!))
(define (make-dnsddb-options . stuff)
(let loop ((options (make-default-dnsddb-options))
(stuff stuff))
(if (null? stuff)
options
(let* ((transformer (car stuff))
(value (cadr stuff)))
(loop (transformer value options)
(cddr stuff))))))
(define (make-db-options-from-list o-list)
(let ((options (make-default-dnsddb-options)))
(if (eq? (car o-list) 'zone)
(begin
(for-each
(lambda (e)
(let ((id (car e))
(value (cadr e)))
(case id
((name)
(if (string? value)
(set-dnsddb-options-name!
options (make-fqdn-name value))
(error "Bad option argument.")))
((type)
(if (or (string-ci=? "primary" value)
(string-ci=? "secondary" value)
(string-ci=? "master" value)
(string-ci=? "slave" value))
(set-dnsddb-options-type! options value)
(error "Bad option argument.")))
((file)
(if (and (string? value) (file-name-non-directory? value))
(set-dnsddb-options-file! options value)
(error "Bad option argument.")))
((filetype)
(if (or (string-ci=? "dnsd" value)
(string-ci=? "rfc" value))
(set-dnsddb-options-filetype! options value)
(error "Bad option argument.")))
((master-name)
(if (string? value)
(set-dnsddb-options-master-name! options value)
(error "Bad option argument.")))
((master-ip)
(if (string? value)
(set-dnsddb-options-master-ip! options value)
(error "Bad option argument.")))
(else (error "Bad option.")))))
(cdr o-list))
options)
(error "Not an option list."))))

836
scheme/dnsd/dnsd.scm
View File

@ -1,836 +0,0 @@
; ------------------
; --- DNS-Server ---
; ------------------
; A DNS-Server based on the RFCs: 1034 / 1035
; This file is (maybe) part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; TODO:
; -----
; Testing, testing, testing...
; Nice stuff to have:
; * IXFR
; * IPv6-Support
; * Support more types (& other classes)
; * Masterfile-parser: $GENERATE ...
; * Some accurate way to limit the cache to a certain mem-size?
; * Better syslog interaction.
; Doc-TODO:
; - Master-File-Parser
; - Cache
; - Database
; - dnsd messages
; - dnsd-options
; Message Example (Query):
; ------------------------
; (define *query-example*
; (make-message (make-header 0815 (make-flags 1 0 #f #f #f #f 0 0) 1 0 0 0)
; (list (make-question "uni-tuebingen.de."
; (message-type a)
; (message-class in)))
; '() '() '() '()))
;; Assignment procedures for messages (basically dns.scm extension)
;; ----------------------------------------------------------------
;; Set the truncation bit of an octet-message (for UDP):
;; TYPE: message x boolean -> message
(define (octet-msg-change-truncation msg bool)
(let* ((id (take msg 2))
(rest (drop msg 3))
(flag (char->ascii (caddr msg)))
(flag-RD (if (even? flag) 0 1))
(flag-shift (arithmetic-shift flag -2)))
(append id (list (ascii->char
(+ flag-RD (arithmetic-shift
(+ (if bool 1 0)
(arithmetic-shift flag-shift 1)) 1))))
rest)))
;; Interpreting the results of db-lookup-rec. Is there a zone in the db:
;; TYPE: '(list-of-ans list-of-aut list-of-add boolean) -> boolean
(define (no-zone? res-l)
(and (null? (car res-l)) (null? (cadr res-l))
(null? (caddr res-l)) (not (cadddr res-l))))
;; A reply is chacheworthy if it contains no errors and is authoritative.
;; TYPE: message -> boolean
(define (msg-cachable? msg)
(and (eq? 'dns-no-error (flags-response-code
(header-flags (message-header msg))))
(flags-authoritative? (header-flags (message-header msg)))))
;; ------------
;; --- AXFR ---
;; ------------
;; AXFR is triggered by the zone-management-thread below:
;; TYPE: rr x string x message-class x dnsd-options -> boolean
(define (axfr-update soa-rr zone-name class dnsd-options dnsddb-options)
;; Search for the primary nameserver (msg) & get the soa-rr (msg2)
;; TYPE: string x string x message-class x dnsd-options -> soa-rr x ns-ip
(define (receive-soa-message ns-name name class dnsd-options dnsddb-options)
(let* ((ip? (dnsddb-options-master-ip dnsddb-options))
;; Lookup the IP or use dnsddb-options-master-ip
(nameserver
(if (and ip? (ip-string? ip?))
(ip-string->address32 ip?)
(let* ((msg (dnsd-ask-resolver-rec
(make-simple-query-message ns-name
(message-type a) class)
(network-protocol udp) dnsd-options))
(error-cond (flags-response-code
(header-flags
(message-header msg)))))
(if (eq? 'dns-no-error error-cond)
(resource-record-data-a-ip
(resource-record-data
(car (message-answers msg))))
(begin
(dnsd-log (syslog-level debug)
"AXFR: Error (~S) during rec.-lookup for the address of the primary NS for zone ~S."
error-cond
name)
#f))))))
(if nameserver
(let* ((msg2 (dnsd-ask-resolver-direct
(make-simple-query-message name (message-type soa)
class)
(list nameserver) (network-protocol udp) dnsd-options))
(error-cond (flags-response-code
(header-flags (message-header msg2)))))
(if (eq? 'dns-no-error error-cond)
(values (car (message-answers msg2)) nameserver)
(begin
(dnsd-log (syslog-level debug)
"AXFR: Error (~S) during rec.-lookup for the SOA-record of the primary NS for zone ~S."
error-cond
name)
(values #f #f))))
(values #f #f))))
;; Try to receive an zone with an AXFR-request:
(define (receive-axfr-message name class nameserver dnsd-options)
(let* ((msg (dnsd-ask-resolver-direct
(make-simple-query-message name (message-type axfr) class)
nameserver (network-protocol tcp) dnsd-options))
(error-cond (flags-response-code (header-flags
(message-header msg)))))
(if (eq? error-cond 'dns-no-error)
(message-answers msg)
(begin
(dnsd-log (syslog-level debug)
"AXFR: Error (~S) during AXFR-request for zone ~S"
error-cond
name)
#f))))
(let* ((soa-data (resource-record-data soa-rr))
(zone-mname (resource-record-data-soa-mname soa-data))
(zone-serial (resource-record-data-soa-serial soa-data)))
(dnsd-log (syslog-level info)
"AXFR: Starting AXFR-Update for zone ~S"
(resource-record-name soa-rr))
(receive
(new-soa nameserver)
(receive-soa-message zone-mname zone-name class dnsd-options dnsddb-options)
(if (not new-soa)
#f
;; Compare the serials of the local and remote soa-rrs to decide
;; if an update is neccessary.
(if (< zone-serial (resource-record-data-soa-serial
(resource-record-data new-soa)))
;; Try an (AXFR)-Update...
(let ((axfr-zone (receive-axfr-message zone-name class
(list nameserver)
dnsd-options)))
(if axfr-zone
(begin
(let ((first (resource-record-data (car axfr-zone)))
(last (resource-record-data
(list-ref axfr-zone
(- (length axfr-zone) 1)))))
(if (and (resource-record-data-soa? first)
(resource-record-data-soa? last))
(begin
(dnsd-log (syslog-level info)
"AXFR: Received AXFR-Reply for zone ~S. Starting database-update."
zone-name)
(db-update-zone (cdr axfr-zone)))
#f)))
#f))
#t)))))
;; ---------------------------------------------
;; --- Query-lookup in database and/or cache ---
;; ---------------------------------------------
;; Currently supported types:
;; TYPE: message-type -> boolean
(define (dnsd-supported-type? type)
(not (null? (filter (lambda (e) (eq? type e))
(list (message-type a)
(message-type ns)
(message-type cname)
(message-type soa)
(message-type ptr)
(message-type hinfo)
(message-type mx)
(message-type txt)
(message-type axfr)
(message-type mailb); Mailbox-related rrs. Here: mx
(message-type *))))))
;; TODO: Find out how to handle a standard query with multiple questions?
;; Should that be allowed at all?
;; Main algorithm for incoming queries. Responsibilities:
;; - decides if the query-type is implemented
;; - decides if and when to use cache/db-lookup/recursive lookup
;; TYPE: message x dnsd-options -> message
(define (lookup-query query dnsd-options)
(let ((query-flags (header-flags (message-header query))))
;; What OPCODE do we have here?
(cond
;; * [1] standard query (the only supported so far)
((= 0 (flags-opcode query-flags))
(let* ((question (car (message-questions query)))
(qname (question-name question))
(qclass (question-class question))
(qtype (question-type question)))
;; What kind of QTYPE do we have?
(cond
;; AXFR (252): A zone transfer... .
((and (eq? (message-type axfr) qtype)
(dnsd-options-use-axfr? dnsd-options))
(let ((zone (db-get-zone-for-axfr qname qclass)))
;; TODO: Is it okay to send the whole zone?
;; Maybe there should be checked who is asking?
(make-response query (list zone '() '() #t) dnsd-options)))
;; Supported QTYPES:
((dnsd-supported-type? qtype)
;; Try to get a database reply
(let ((res-l (if (dnsd-options-use-db? dnsd-options)
(receive
(anli auli adli aufl)
(db-lookup-rec qname qclass qtype)
(list anli auli adli aufl))
(list '() '() '() #f))))
;; Use recursion for local-result: '(() () () #f)
(if (and (dnsd-options-use-recursion? dnsd-options)
(no-zone? res-l)
(flags-recursion-desired? query-flags))
(dnsd-ask-resolver-rec query (network-protocol udp) dnsd-options)
(make-response query res-l dnsd-options))))
;; Unsupported QTYPEs:
(else (msg-set-rcode! query 4) query))))
;; This kind of queries are not implemented:
;; * [2] inverse query (not really used anymore (see RFC 3425))
;; * [3] server status request (marked experimental in RFC 1035)
;; * [4-15] reserved for future use (RFC 1035)
(else (msg-set-rcode! query 4) query))))
;; --------------
;; --- Server ---
;; --------------
;; Management of a zone:
;; ---------------------
;; Management consists of periodically checking the local files for
;; new information for primary-zones and to trigger AXFR-Updates for secondary
;; zones.
;; TYPE channel x channel x dnsd-options x dnsddb-options -> new-thread
(define (dnsd-zone-mgt-thread ch-usr1 ch-usr2 dnsd-options dnsddb-options)
(define (wait-thread zone-refresh ch-wakeup dnsd-options)
(fork-thread
(lambda ()
(let ((refresh (* zone-refresh 1000)))
(if (< refresh (dnsd-options-retry-interval dnsd-options))
(sleep (dnsd-options-retry-interval dnsd-options))
(sleep refresh))
(sync (send-rv ch-wakeup #t))))))
(let* ((dnsd-options dnsd-options)
(ch-wakeup (make-channel))
(zone-name (dnsddb-options-name dnsddb-options))
(type (dnsddb-options-type dnsddb-options))
(primary? (or (string-ci=? type "master")
(string-ci=? type "primary")))
(class (dnsddb-options-class dnsddb-options)))
(fork-thread
(lambda ()
(let refresh-loop ()
(let* ((soa-data (resource-record-data
(db-get-zone-soa-rr zone-name class)))
(zone-refresh (resource-record-data-soa-refresh soa-data))
(retry-val (resource-record-data-soa-retry soa-data))
(expire-val (resource-record-data-soa-expire soa-data)))
;; Start thread for wakeup-channel:
(wait-thread zone-refresh ch-wakeup dnsd-options)
(let inner-loop ()
(sync
(choose
;; Set new dnsd-options:
(wrap (receive-rv ch-usr1)
(lambda (new-dnsd-options)
(set! dnsd-options new-dnsd-options)
(inner-loop)))
;; Terminate the thread if a reload is signaled:
(wrap (receive-rv ch-usr2)
(lambda (ignore) #t))
;; Try a refresh:
(wrap (receive-rv ch-wakeup)
(lambda (ignore)
(dnsd-log (syslog-level info)
"Reloading zone ~S"
zone-name)
;; Primary or secondary zone?
(if (if primary?
(not
(dnsd-reload-zone dnsd-options dnsddb-options))
(axfr-update (db-get-zone-soa-rr zone-name class)
zone-name class dnsd-options
dnsddb-options))
;; Case the refresh didn't work:
(if (< expire-val 0)
(begin
(dnsd-log (syslog-level info)
"Zone ~S expired. Deleting from db!"
zone-name)
(db-clear-zone zone-name class)
(inner-loop)) ;; Wait for termination...
(begin
(set! expire-val (- expire-val retry-val))
(wait-thread retry-val ch-wakeup dnsd-options)
(set! retry-val (* 2 retry-val))
(inner-loop)))
(refresh-loop)))))))))))))
;; Reload options from dnsd-options.scm:
;; -------------------------------------
;; If an error occures (malformed file etc.) the old options are used as the
;; return value.
;; TYPE: dnsd-options -> dnsd-options
(define (dnsd-reload-options dnsd-options)
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while reloading dnsd-options.scm")
;(dnsd-log (syslog-level debug)"Above condition is: ~A" condition)
dnsd-options)
(lambda ()
(let ((path (dnsd-options-dir dnsd-options)))
(dnsd-log (syslog-level info)
"Reloading dnsd-options.scm with path: ~S"
path)
(let* ((port (if (file-name-directory? path)
(open-input-file (string-append path "dnsd-options.scm"))
(begin
(dnsd-log (syslog-level info)
"Bad path (~S) in dnsd-options. Trying ./dnsd-options.scm"
path)
(open-input-file "./dnsd-options.scm"))))
(options? (read port)))
(close-input-port port)
(make-options-from-list options? dnsd-options))))))
;; (Re)load zones from dnsd-zones.scm:
;; -----------------------------------
;; Make a fake secondary zone for the management thread:
;; TYPE: dnsddb-options -> list-of-rrs
(define (make-sec-zone dnsddb-options)
(list
(dns-rr-soa (dnsddb-options-name dnsddb-options)
(message-class in)
0
(list
(dnsddb-options-master-name dnsddb-options)
"unknown.mail-adress."
0 ;; smallest serial possible
5 ;; fast first fetch
(* 60 10) ;; fast retry
(* 60 60 24 7) ;; expires
0)))) ;; min TTL
;; Reload a zone...
;; TYPE: zone x string x dnsd-options -> boolean
(define (dnsd-reload-zone dnsd-options dnsddb-options)
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while reloading a zone.")
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
#f)
(lambda ()
(let* ((path (dnsd-options-dir dnsd-options))
(file (dnsddb-options-file dnsddb-options))
(zone-name (dnsddb-options-name dnsddb-options)))
;; Handle secondary zones...
(if (dnsddb-options-master-name dnsddb-options)
(db-update-zone (make-sec-zone dnsddb-options))
;; handle primary zones
(and-let* ((zone-list (if (string-ci=?
(dnsddb-options-filetype dnsddb-options)
"rfc")
(parse-mf file dnsd-options)
(load (string-append path file))))
(soa-zone-name (maybe-get-soa-rr-name zone-list)))
(if (string-ci=? zone-name soa-zone-name)
(db-update-zone zone-list)
(begin
(dnsd-log (syslog-level info)
"Zone names doesn't fit between file (%S) and dnsd-zones (%S)"
soa-zone-name zone-name)
(error " ")))))))))
;; Initialize // reload the zones which are defined in dnsd-zones.scm
;; TYPE: channel x channel x dnsd-options -> unspecific
(define (dnsd-reload-dnsd-zones ch-usr1 ch-usr2 dnsd-options)
(let ((usr1-channel-list '())
(usr2-channel-list '())
(dnsd-options dnsd-options))
(fork-thread
(lambda ()
(let loop ()
(sync
(choose
(wrap (receive-rv ch-usr1)
(lambda (new-dnsd-options)
(set! dnsd-options new-dnsd-options)
(for-each (lambda (e) (sync (send-rv e new-dnsd-options)))
usr1-channel-list)
(loop)))
(wrap
(receive-rv ch-usr2)
(lambda (ignore)
;; Terminate all old management-threads:
(for-each (lambda (e) (sync (send-rv e 'terminate)))
usr2-channel-list)
(set! usr1-channel-list '())
(set! usr2-channel-list '())
;; Clear database:
(db-clear-database)
(if (dnsd-options-use-db? dnsd-options)
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while reloading dnsd-zones.scm")
#f)
(lambda ()
(let* ((path (dnsd-options-dir dnsd-options))
(port (if (file-name-directory? path)
(open-input-file
(string-append path "dnsd-zones.scm"))
(begin
(dnsd-log (syslog-level info)
"Bad path (~S) in dnsd-zones. Trying ./dnsd-zones.scm"
path)
(open-input-file "./dnsd-zones.scm"))))
(zone-l (read port)))
(close-input-port port)
(if (list? zone-l)
(for-each
(lambda (e)
(let ((dnsddb-options (make-db-options-from-list e))
(ch-usr1-thread (make-channel))
(ch-usr2-thread (make-channel)))
(if (dnsd-reload-zone dnsd-options dnsddb-options)
(begin
(dnsd-zone-mgt-thread ch-usr1-thread
ch-usr2-thread
dnsd-options
dnsddb-options)
(set! usr1-channel-list
(cons ch-usr1-thread
usr1-channel-list))
(set! usr2-channel-list
(cons ch-usr2-thread
usr2-channel-list))))))
zone-l)
(begin
(dnsd-log (syslog-level info)
"Bad sytax in dnsd-zones.scm.")
#f)))))
#f)
(loop))))))))))
;; Management of the datastructures (Cache / SLIST / Blacklist)
;; ------------------------------------------------------------
;; Clean dnsd-cache/slist every now and then.
;; TYPE: channel x dnsd-options -> unspecific
(define (dnsd-management-thread ch-usr1 dnsd-options)
(fork-thread
(lambda ()
(let ((ch-wait (make-channel))
(dnsd-options dnsd-options))
(let loop ()
(let ((time-in-sec (dnsd-options-cleanup-interval dnsd-options)))
;; Starting this thread to wait on ch-wait:
(fork-thread
(lambda ()
(sleep (* time-in-sec 1000))
(sync (send-rv ch-wait 'whatever))))
(sync
(choose
(wrap (receive-rv ch-wait)
(lambda (ignore)
(if (dnsd-options-use-cache? dnsd-options)
(dnsd-cache-clean!))
(dnsd-slist-clean!)
;; deprecated (dnsd-blacklist-clean! dnsd-options)
(dnsd-log (syslog-level info)
"Cleaned CACHE and SLIST. Current interval is ~D seconds."
time-in-sec)
#t))
(wrap (receive-rv ch-usr1)
(lambda (value) (set! dnsd-options value)))))
(loop)))))))
;; Pre- and post-processing of messages:
;; -------------------------------------
(define (dnsd-pre message socket-addr dnsd-options)
(dnsd-pre/post message socket-addr dnsd-options "dnsd-pre.scm"))
(define (dnsd-post message socket-addr dnsd-options)
(dnsd-pre/post message socket-addr dnsd-options "dnsd-post.scm"))
;; Load the pre- and post-processing files...
;; TYPE: msg x socket-addr x dnsd-options x string -> msg x dnsd-options
(define (dnsd-pre/post message socket-addr dnsd-options file)
(if (dnsd-options-use-pre/post dnsd-options)
(with-fatal-error-handler*
(lambda (condition decline)
(values message dnsd-options))
(lambda ()
(let* ((dir (dnsd-options-dir dnsd-options))
(path (if (file-name-directory? dir)
(string-append dir file)
(begin
(dnsd-log (syslog-level info)
"Bad dir (~S) in options. Trying ./~S"
dir file)
(string-append "./" file)))))
((load path) message socket-addr dnsd-options))))
(values message dnsd-options)))
;; UDP thread:
;; -----------
;; Starts the main UDP-loop:
;; TYPE: socket x channel x dnsd-options -> unspecific
(define (dnsd-server-loop-udp socket ch-usr1 dnsd-options)
(let ((ch-receive (make-channel))
(max-con (make-semaphore (dnsd-options-max-connections dnsd-options)))
(dnsd-options dnsd-options))
;; Thread for incoming UDP-messages:
(fork-thread
(lambda ()
(let loop ()
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while processing a UDP-query.")
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
;(loop))
decline)
(lambda ()
(semaphore-wait max-con)
(receive
(msg addr)
(receive-message/partial socket 512)
(sync (send-rv ch-receive (cons msg addr)))
(loop)))))))
;; Choose between user-interrupt or query-processing
(fork-thread
(lambda ()
(let loop ()
(sync
(choose
(wrap (receive-rv ch-receive)
(lambda (value)
(udp-processing-thread (car value) (cdr value)
socket max-con dnsd-options)))
(wrap (receive-rv ch-usr1)
(lambda (value)
(set! dnsd-options value)
(set-semaphore! max-con (dnsd-options-max-connections
dnsd-options))))))
(loop))))))
;; Start the thread for processing a UDP-query.
;; TYPE: message x address x socket x dnsd-options -> unspecific
(define (udp-processing-thread msg addr socket max-con dnsd-options)
(fork-thread
(lambda ()
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while processing a UDP-query.")
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
(semaphore-post max-con)
;#f)
decline)
(lambda ()
(let ((msg (parse (string->list msg))))
(if (not msg)(error "Couldn't parse the message."))
;; Preprocess the message...
(receive
(msg dnsd-options)
(dnsd-pre msg addr dnsd-options)
(if (not msg) (semaphore-post max-con)
(let* ((msg-header (message-header msg))
(msg-flags (header-flags msg-header))
(msg-trunc? (flags-truncated? msg-flags)))
(if msg-trunc? (error "Couldn't process truncated query."))
(let ((reply (lookup-query msg dnsd-options)))
(if (not reply) (error "Lookup produced no reply."))
;; Postprocessing the message:
(receive
(reply dnsd-options)
(dnsd-post reply addr dnsd-options)
(if (not reply) (semaphore-post max-con)
(let* ((octet-list (mc-message->octets reply))
(l (length octet-list)))
(if (> l 512) ; Use message-truncation?
(let* ((msg (octet-msg-change-truncation
octet-list #t))
(to-send (list->string (take msg 512))))
(receive
(host-addr port)
(socket-address->internet-address addr)
(dnsd-log (syslog-level info)
"Sending truncated UDP-response to: ~A"
(address32->ip-string host-addr))
(send-message socket to-send 0 511 0 addr)))
(begin
(send-message socket (list->string octet-list)
0 l 0
addr)))
(semaphore-post max-con))))))))))))))
;; TCP thread:
;; -----------
;; Main TCP-loop:
;; TYPE: socket x channel x dnsd-options -> unspecific
(define (dnsd-server-loop-tcp socket ch-usr1 dnsd-options)
(let ((ch-receive (make-channel))
(max-con (make-semaphore (dnsd-options-max-connections dnsd-options)))
(dnsd-options dnsd-options))
;; Thread for incoming TCP-messages:
(fork-thread
(lambda ()
(let loop ()
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while processing a TCP-query.")
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
(loop))
;decline)
(lambda ()
(semaphore-wait max-con)
(receive
(private-socket addr)
(accept-connection socket)
(sync (send-rv ch-receive (cons private-socket addr)))
(loop)))))))
;; Choose between user-interrupt or query-processing
(fork-thread
(lambda ()
(let loop ()
(sync
(choose
(wrap (receive-rv ch-receive)
(lambda (value)
(tcp-processing-thread (car value) (cdr value)
max-con dnsd-options)))
(wrap (receive-rv ch-usr1)
(lambda (value)
(set! dnsd-options value)
(set-semaphore! max-con (dnsd-options-max-connections
dnsd-options))))))
(loop))))))
;; Start the thread for processing a TCP-query:
;; TYPE: address x socket x dnsd-options -> unspecific
(define (tcp-processing-thread socket addr max-con dnsd-options)
(fork-thread
(lambda ()
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while processing a TCP-query.")
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
(semaphore-post max-con)
(close-socket socket) #f)
(lambda ()
(let* ((inport (socket:inport socket))
(outport (socket:outport socket))
;; A tcp-message has a 2-octet-length size tag:
(front (read-char inport))
(rear (read-char inport))
(size-tag (octet-pair->number front rear))
(octet-msg (read-string size-tag inport))
(msg (parse (string->list octet-msg))))
(if (not msg)(error "Couldn't parse the message"))
;; Preprocessing:
(receive
(msg dnsd-options)
(dnsd-pre msg addr dnsd-options)
(if (not msg)
(begin
(semaphore-post max-con)
(close-socket socket))
(let* ((msg-header (message-header msg))
(msg-flags (header-flags msg-header))
(msg-trunc? (flags-truncated? msg-flags)))
(if msg-trunc? (error "Couldn't process truncated query."))
(let ((reply (lookup-query msg dnsd-options)))
(if (not reply) (error "Lookup produced no reply."))
;; Postprocessing:
(receive
(reply dnsd-options)
(dnsd-post reply addr dnsd-options)
(if (not reply)
(begin
(semaphore-post max-con)
(close-socket socket))
(let* ((reply (mc-message->octets reply))
(l (number->octet-pair (length reply))))
(write-string (list->string (append l reply)) outport)
(semaphore-post max-con)
(close-socket socket))))))))))))))
;; Initialize and start UDP and TCP threads:
;; TYPE: dnsd-options -> unspecific
(define (init-dnsd dnsd-options)
(let ((ch-usr1-udp (make-channel))
(ch-usr1-tcp (make-channel))
(ch-usr1-mgt (make-channel))
(ch-usr1-zones (make-channel))
(ch-usr2-zones (make-channel))
(dnsd-options dnsd-options))
(call-with-current-continuation
(lambda (escape)
;; Maybe load the options from file:
(set! dnsd-options (dnsd-reload-options dnsd-options))
;; Initializing signal-handler(s)
;; * USR1 (reload dnsd-options.scm)
;; Log debug-level in syslog?
(with-syslog-destination
(string-append "dnsd (" (number->string (pid)) ")")
#f
#f
(if (dnsd-options-debug-mode dnsd-options)
(syslog-mask-upto (syslog-level info))
#f)
(lambda ()
(set-interrupt-handler
interrupt/usr1
(lambda (ignore)
(dnsd-log (syslog-level info)
"Interrupt/USR1: Reloading options.")
(set! dnsd-options (dnsd-reload-options dnsd-options))
(fork-thread
(lambda () (sync (send-rv ch-usr1-udp dnsd-options))))
(fork-thread
(lambda () (sync (send-rv ch-usr1-tcp dnsd-options))))
(fork-thread
(lambda () (sync (send-rv ch-usr1-mgt dnsd-options))))
(fork-thread
(lambda () (sync (send-rv ch-usr1-zones dnsd-options))))))
;; * USR2 (reload dnsd-zones.scm)
(set-interrupt-handler
interrupt/usr2
(lambda (ignore)
(dnsd-log (syslog-level info)
"Interrupt/USR2: Reloading zones.")
(sync (send-rv ch-usr2-zones 'ignore))))
;; Initializing cleanup thread:
(dnsd-management-thread ch-usr1-mgt dnsd-options)
;; Initialize & load the database:
(dnsd-reload-dnsd-zones ch-usr1-zones ch-usr2-zones dnsd-options)
(sync (send-rv ch-usr2-zones 'ignore))
;; Initializing tcp/upd sockets & start thread:
(let* ((the-port (dnsd-options-port dnsd-options))
(udp-socket (create-socket protocol-family/internet
socket-type/datagram))
(tcp-socket (create-socket protocol-family/internet
socket-type/stream))
(socket-addr (internet-address->socket-address
internet-address/any the-port)))
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Coudn't start dnsd. Port ~D is already in use."
the-port)
(close-socket udp-socket)
(close-socket tcp-socket)
(escape 'douh!))
(lambda ()
(dnsd-log (syslog-level info)
"Starting the service on port: ~D"
the-port)
(bind-socket udp-socket socket-addr)
(bind-socket tcp-socket socket-addr)
(listen-socket tcp-socket 10))) ; TODO: How big should the queue be?
;; Start the UDP-Loop:
(fork-thread (lambda () (dnsd-server-loop-udp udp-socket ch-usr1-udp
dnsd-options)))
;; Start the TCP-Loop:
(fork-thread (lambda () (dnsd-server-loop-tcp tcp-socket ch-usr1-tcp
dnsd-options))))))))))
;; Entry-Point for run-dnsd
;; ------------------------
(define (dnsd-start . dir)
(with-syslog-destination
(string-append "dnsd (" (number->string (pid)) ")") #f #f #f
(lambda ()
(if (null? dir)
(init-dnsd (make-default-dnsd-options))
(init-dnsd (with-dir
(file-name-as-directory (car dir))
(make-default-dnsd-options)))))))

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

@ -1,103 +0,0 @@
;; Option-File for DNSD:
;; ---------------------
;; Options can be reloaded using the POSIX-Signal USR1.
;; External option representation <datum>:
;; ---------------------------------------
;; (options
;; [dir string]
;; [nameservers list-of-ip-strings]
;; [use-axfr boolean]
;; [use-cache boolean]
;; [cleanup-interval time-in-sec]
;; [retry-interval time-in-sec]
;; [use-db boolean]
;; [use-recursion boolean]
;; [rec-timeout time-in-s]
;; [socket-timeout time-in-s]
;; [socket-max-tries integer]
;; [max-connections integer]
;; [blacklist-time time-in-s]
;; [blacklist-value integer]
;; [use-pre/post boolean])
;; [...] indicates an optional list.
;; Semantic:
;; ---------
;; (dir string)
;; Path to the directory with this configuration files.
;; Standard value is "." - the dir where dnsd was started or the
;; directory which was passed to (dnsd-start <optional-dir>)
;; (nameservers list-of-ip-strings)
;; A list of nameserver-IPs used for recursive lookups.
;; Standard value is a list of root-nameservers.
;; (use-axfr boolean)
;; Toggles to answer to axfr-requests. Default value is #t.
;; (use-cache boolean)
;; Toggles caching of responses. Default value is #t.
;; (cleanup-interval time-in-sec)
;; Clean the cache and slist after X seconds. Default value is 1h.
;; (retry-interval time-in-sec)
;; Minimum value in seconds to trigger zone-reloads. This can override
;; the value of some masterfiles. Default value is 1h.
;; (use-db boolean boolean)
;; Toggle the usage of the local database. Default value is on - #t.
;; (use-recursion boolean)
;; Switch the recursive-lookup on/off. Default value is on - #t.
;; (rec-timeout time-in-sec)
;; Global timeout for a recursive lookup. Default is 10 seconds.
;; (socket-timeout time-in-sec)
;; Timeout for one lookup during a recursive lookup. Default is 2 seconds.
;; (socket-max-tries integer)
;; Maximum nuber of tries to establish a connection for recursive lookups.
;; Default value is 3.
;; (max-connection integer)
;; Maximum concurrent connections for each UDP and TCP. Default is 25.
;; (blacklist-time time-in-sec)
;; How long will a bad NS be blacklisted/not used? Default is 30 min.
;; (blacklist-value integer)
;; How often, before a bad NS will be ignored? Default is 5 times.
;; (use-pre/post boolean)
;; Toggles load of pre- and post-processing files. Default is off - #f.
;; all args are optional. If not given, the def. value will be used.
;; Some examples:
;; --------------
;;
;; (options (nameservers ("192.168.2.1" "192.168.2.2"))
;; (use-axfr #t)
;; (use-cache #t)
;; (cleanup-interval 666)
;; (use-recursion #t)
;; (use-db #f)
;; (use-pre/post #f))
;;
;; (options) == use the default values.
;;
;; OPTION-DEFINITIONS:
(options)

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

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

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

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

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

@ -1,80 +0,0 @@
;; Zones-File for DNSD:
;; --------------------
;; The local zones of the NS can be reloaded using the
;; POSIX signal USR2.
;; External zones representation <datum>:
;; --------------------------------------
;; zone-file ::= list-of-zone-lists
;; list-of-zone ::= primary-zone | secondary-zone
;; primary-zone ::= (zone (name string)
;; (type "master" or "primary")
;; (file string)
;; [filetype string])
;; secondary-zone ::= (zone (name string)
;; (type "slave" or "secondary")
;; (master-name string)
;; [master-ip ip-string])
;; [...] is an optional list.
;; Semantic:
;; ---------
;; list-of-zone-lists
;; A list containing all zones of the NS.
;; list-of-zone
;; A list containing the options for one zone of the NS.
;; (name string)
;; The fully-qualified-domain-name of the zone.
;; (type "master" or "slave")
;; The type of the zone. One of the two strings: "master" or "slave".
;; Alternatively, it can be "primary" or "secondary".
;; (file string)
;; The filename of the masterfile.
;; (filetype string)
;; One of the two strings "dnsd" or "rfc". Default is "dnsd".
;; (master-name string)
;; The domain-name of the master-nameserver.
;; (master-ip ip-string)
;; The IP of the master-nameserver. If non given, DNSD will try to
;; lookup the IP.
;; Examples:
;; --------
;; () == No zones given. Use dnsd as a resolver only.
;;
;; Try the examples and be a secondary NS for the domain "porsche.de"
;;
;;((zone (name "my.example.")
;; (type "master")
;; (file "zone-example-scheme"))
;; (zone (name "example.com.")
;; (type "master")
;; (file "zone-example-rfc")
;; (filetype "rfc")))
;; (zone (name "porsche.de.")
;; (type "slave")
;; (master-name "dns01.fw.porsche.de."))
;; DEFINE HERE:
()

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

@ -1,30 +0,0 @@
$ORIGIN example.com.
$TTL 2D
example.com. IN SOA gateway root.example.com. (
2003072441 ; serial
1D ; refresh
2H ; retry
1W ; expiry
2D ) ; minimum
IN NS gateway
IN MX 10 sun
gateway IN A 192.168.0.1
IN A 192.168.1.1
sun IN A 192.168.0.2
moon IN A 192.168.0.3
earth IN A 192.168.1.2
mars IN A 192.168.1.3
www IN CNAME venus
; A cname-loop...
venus IN CNAME saturn
saturn IN CNAME venus
; Glue Data
nofreude IN NS ns1.nofreude
ns1.nofreude IN A 192.168.2.66

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

@ -1,19 +0,0 @@
; Zone-example using the functions from dnsd/rr-def.scm and lib/dns.scm
; ---------------------------------------------------------------------
(let ((mc (message-class in))
(ttl (* 60 60 24)))
(list
(dns-rr-soa "my.example." mc ttl
(list "nameserver.my.example." "webmaster.my.example"
20051203 7200 600 300000 1111))
(dns-rr-a "my.example." mc ttl "192.168.2.1")
(dns-rr-ns "my.example." mc ttl "nameserver.my.example.")
(dns-rr-a "on.my.example." mc ttl "192.168.2.2")
(dns-rr-a "*.my.example." mc ttl "192.168.2.3")
(dns-rr-mx "my.example" mc ttl (list 11 "mx.my.example"))
(dns-rr-cname "cname.my.example" mc ttl "my.example")
(dns-rr-a "mx.my.example" mc ttl "192.168.2.4")
(dns-rr-ns "ns.my.example" mc ttl "ns.test.")
(dns-rr-ns "more.my.example" mc ttl "ns2.my.example")
(dns-rr-a "ns2.my.example" mc ttl "192.168.2.11")))

34
scheme/dnsd/logging.scm
View File

@ -1,34 +0,0 @@
; ------------------------
; --- Syslog-Interface ---
; ------------------------
; Syslog/Debug-Stuff for dnsd.
; This file is (maybe) part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
(define *debug-info* #f) ; switch debug-information on/off
;; TODO: log-file instead of display-information:
;; Show some debug-information
(define display-debug
(lambda args
(if *debug-info*
(begin
(display "dnsd: ")
(map (lambda (e) (display e) (display " ")) args)
(newline))
#f)))
(define (apply-w/debug proc . args)
(if *debug-info* (apply proc args)))
(define (dnsd-log log-level msg . args)
(syslog log-level (apply format #f msg args)))

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

@ -1,369 +0,0 @@
; -------------------------
; --- Masterfile-Parser ---
; -------------------------
; Parser for Masterfiles based on the RFCs: 1034 / 1035 / 2308 and
; the BIND-Time-Value-Format convention.
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Interface:
; ----------
; (parse-mf fileaname dnsd-options) -> list-of-resource-records
;; Lexer:
;; ------
;; The lexer was generated using SILex v1.0 by Danny Dubé with
;; specification file "masterfile.l"
;; For more information about SILex visit: http://www.iro.umontreal.ca/~dube/
;; TYPE: filename x dnsd-options -> list-of-lexems or #f
(define (lex-masterfile file dnsd-options)
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level info)
"Error while parsing the file ~S"
file)
(dnsd-log (syslog-level debug)
"Above condition is: ~A"
condition)
#f)
(lambda ()
(and-let* ((the-path (string-append (dnsd-options-dir dnsd-options) file))
(whatever (file-name-non-directory? the-path))
(the-port (open-input-file the-path)))
(lexer-init 'port the-port)
(let loop ((l '()))
(let ((lexem (lexer)))
(if (eq? lexem 'eof)
(begin
(close-input-port the-port)
(reverse (cons lexem l)))
(loop (cons lexem l)))))))))
;; Parser:
;; -------
;; Maybe append a domain-origin to a string:
;; TYPE: dn-label-string x fqdn-string -> fqdn-string
(define (parse-mf-maybe-append-origin name origin)
(let ((l (string-length name)))
(if (and (not (= 0 l)) (not (char=? #\. (string-ref name (- l 1)))))
(if (string=? origin ".")
(string-append name origin)
(string-append name "." origin))
name)))
;; Parse (or restore) the name of the current line:
;; TYPE: dn-label-string or symbol x fqdn-string x dn-label-string ->
;; fqdn x dn-label-string
(define (parse-mf-node-name? elem origin last-name)
(cond
((eq? elem 'origin-ref) (values origin origin)) ; @ in the masterfile
((eq? elem 'blank) ; no name given - use last one
(values (parse-mf-maybe-append-origin last-name origin) last-name))
(else (values (parse-mf-maybe-append-origin elem origin) elem))))
;; Parse the type of a rr-line:
;; TYPE: string -> message-type
(define (parse-mf-type? elem)
(message-type-symbol->type (string->symbol (string-downcase elem))))
;; Parse the class of a rr-line:
;; TYPE: string -> message-class
(define (parse-mf-class? elem)
(message-class-symbol->type (string->symbol (string-downcase elem))))
;; Parse a RFC-time value or a BIND-Masterfiles value: #w#d#h#m#s
;; eg. 1 Week = 1w or 1d20s = 1 day and 20 seconds
;; This algorithm is very liberal - a possible value would be 12s1d1w1s
;; TYPE: string -> number
(define (parse-mf-time-value? elem)
(let loop ((str elem)
(counter 0)
(val 0))
(let ((l (string-length str)))
(if (= l 0)
val
(let ((sub (substring str counter (+ counter 1))))
(if (string->number sub)
(if (= counter (- l 1))
(string->number str) ; original RFC format
(loop str (+ counter 1) val))
(let ((val2 (string->number (substring str 0 counter)))
(rest-string (substring str (+ counter 1) l)))
(cond
((string-ci=? sub "w")
(loop rest-string 0 (+ val (* 7 24 60 60 val2))))
((string-ci=? sub "d")
(loop rest-string 0 (+ val (* 24 60 60 val2))))
((string-ci=? sub "h")
(loop rest-string 0 (+ val (* 60 60 val2))))
((string-ci=? sub "m")
(loop rest-string 0 (+ val (* 60 val2))))
((string-ci=? sub "s")
(loop rest-string 0 (+ val val2)))
(else
(display elem)
(error "Wrong time-value format"))))))))))
;; Parse a rr-line:
;; Syntax: {<domain>|@|<blank>} [<ttl>] [<class>] <type> <rdata>
;; The algorithm has to guess serveral times which value actually
;; is been parsed.
;; TYPE: rr-line-of-lexems x fqdn x dn-string x ttl-number
;; -> '(name ttl class type rdata origin) x fqdn x dn-string x ttl-number
(define (parse-mf-rr line origin current-rr-name the-ttl)
(receive
(rr-name current-rr-name)
(parse-mf-node-name? (car line) origin current-rr-name)
(let* ((sec (cadr line))
(type (parse-mf-type? sec)))
(if type ; Parsing the type?
(values (list rr-name the-ttl #f type (cddr line) origin)
origin current-rr-name the-ttl)
(let ((class (parse-mf-class? sec)))
(if class ; Parsing a class?
(let ((type (parse-mf-type? (caddr line))))
(values (list rr-name the-ttl class type (cdddr line) origin)
origin current-rr-name the-ttl))
(let ((ttl (parse-mf-time-value? sec)))
(if ttl ; Now it should be a TTL.
(let* ((third (caddr line))
(type (parse-mf-type? third)))
(if type
(values
(list rr-name ttl #f type (cdddr line) origin)
origin current-rr-name the-ttl)
(let ((type (parse-mf-type? (cadddr line))))
(values
(list
rr-name ttl (parse-mf-class? third) type
(cdr (cdddr line)) origin)
origin current-rr-name the-ttl))))
(begin
(display line)
(error "Parsed a bad line!"))))))))))
;; Parse a masterfile-line:
;;<line> ::= $ORIGIN <domain-name>
;; | $INCLUDE ...
;; | $TTL <number> (defined in RFC 2308)
;; | <resource-record>
;; TODO: | $GENERATE ... BIND-Version 9
;;
;; TYPE: mf-line x fqdn x dn-string x ttl-number x dnsd-options
;; -> symbol or list-of-a-rr x fqdn x dn-string x ttl-number
(define (parse-mf-line line origin current-rr-name ttl dnsd-options)
(let ((first (car line)))
(cond
;; $INCLUDE
((eq? first 'include)
(let* ((file-name (cadr line))
(maybe-origin (if (= (length line) 3) (caddr line) #f))
(lexed-file (lex-masterfile file-name dnsd-options))
(line-list (parse-mf-lex->lines lexed-file))
(res (parse-mf-lexem-list
line-list (if maybe-origin maybe-origin origin)
current-rr-name #f dnsd-options)))
(values res origin current-rr-name ttl)))
;; $ORIGIN
((eq? first 'origin)
(let ((new-origin (cadr line)))
(values 'ORIGIN
(parse-mf-maybe-append-origin new-origin origin)
current-rr-name ttl)))
;; $TTL <number>
((eq? first 'ttl)
(let ((new-ttl (cadr line)))
(values 'TTL origin current-rr-name (parse-mf-time-value? new-ttl))))
;; $GENERATE ...
((eq? first 'generate)
(error "parse-masterfile: GENERATE is not supported."))
; <resource-record>
(else (parse-mf-rr line origin current-rr-name ttl)))))
;; Transforms the lexer-output into a list of lines:
;; TYPE: list-of-lexems -> list-of-lexem-lists
(define (parse-mf-lex->lines lex-list)
(let loop ((l lex-list)
(line '())
(ignore-line #f) ; Toggle comments.
(res '()))
(let ((first (car l)))
(cond
((eq? first 'eof)
(if (null? line)
(reverse res)
(reverse (cons line res))))
((eq? first 'left-par) ; Ignore line-breaks.
(loop (cdr l) line #t res))
((eq? first 'right-par) ; Consider line-breaks.
(loop (cdr l) line #f res))
((eq? first 'newline)
(if (not ignore-line)
(if (null? line)
(loop (cdr l) '() ignore-line res)
(loop (cdr l) '() ignore-line (cons line res)))
(loop (cdr l) line ignore-line res)))
((eq? first 'blank-newline)
(if (not ignore-line)
(if (null? line)
(loop (cdr l) (list 'blank) ignore-line res)
(loop (cdr l) (list 'blank) ignore-line (cons line res)))
(loop (cdr l) line ignore-line res)))
(else
(loop (cdr l) (append line (list first)) ignore-line res))))))
;; Actually create a resourc-record from the parsed rr-line:
;; TYPE: '(name ttl class type rdata origin) -> resource-record-data
(define (parse-mf-create-rr line)
(let ((class (caddr line))
(type (cadddr line)))
(if (not (eq? (message-class in) class))
(begin
(display "Message-class not supported: ")
(display class)
(newline))
(let ((name (car line))
(ttl (cadr line))
(data (list-ref line 4))
(origin (list-ref line 5)))
(cond
((eq? type (message-type a))
(dns-rr-a name class ttl (car data)))
((eq? type (message-type ns))
(dns-rr-ns name class ttl
(parse-mf-maybe-append-origin (car data) origin)))
((eq? type (message-type cname))
(dns-rr-cname name class ttl
(parse-mf-maybe-append-origin (car data) origin)))
((eq? type (message-type soa))
(and-let* ((mname (parse-mf-maybe-append-origin (car data) origin))
(rname (parse-mf-maybe-append-origin (cadr data) origin))
(serial (string->number (caddr data)))
(refresh (parse-mf-time-value? (cadddr data)))
(retry (parse-mf-time-value? (list-ref data 4)))
(expire (parse-mf-time-value? (list-ref data 5)))
(minimum (parse-mf-time-value? (list-ref data 6))))
(dns-rr-soa name class ttl
(list mname rname serial
refresh retry expire minimum))))
((eq? type (message-type ptr))
(dns-rr-ptr name class ttl
(parse-mf-maybe-append-origin (car data) origin)))
((eq? type (message-type hinfo))
(dns-rr-hinfo name class ttl data))
((eq? type (message-type mx))
(let ((pref (string->number (car data)))
(exchange (parse-mf-maybe-append-origin (cadr data) origin)))
(dns-rr-mx name class ttl (list pref exchange))))
((eq? type (message-type txt))
(dns-rr-txt name class ttl data))
((eq? type (message-type aaaa))
(dns-rr-aaaa name class ttl (car data)))
(else #f))))))
;; Parse the list-of-lexems and return a list of resource-records:
;; TYPE: list-of-lexems x fqdn x dn-string x ttl-number x dnsd-options
;; -> list-of-resource-records
(define (parse-mf-lexem-list l origin current-rr-name ttl dnsd-options)
(let loop ((l l)
(res '())
(origin origin)
(current-rr-name current-rr-name)
(ttl ttl))
(if (null? l)
res
(receive (next-res origin current-rr-name ttl)
(parse-mf-line (car l) origin current-rr-name ttl
dnsd-options)
(cond
((or (eq? next-res 'ORIGIN)
(eq? next-res 'TTL))
(loop (cdr l) res origin current-rr-name ttl))
((and (list? next-res) ; result from INCLUDE...
(list? (car next-res)))
(loop (cdr l) (append next-res res) origin
current-rr-name ttl))
(else
(loop (cdr l) (cons next-res res) origin
current-rr-name ttl)))))))
;; Stuff for the main parser algorithm:
;; ------------------------------------
;; Searches the results of parse-mf-line for a message-class
(define (get-message-class rrlist)
(let loop ((res rrlist))
(if (null? res)
#f
(let ((class (caddr (car res))))
(if class class
(loop (cdr res)))))))
;; Set the results of parse-mf-line to a message-class...
(define (set-message-class rrlist class)
(map (lambda (e)
(cons (car e) (cons (cadr e) (cons class (cdddr e)))))
rrlist))
;; Searches the results of parse-mf-line for the shortest ttl
(define (get-soa-ttl rrlist)
(let loop ((l rrlist))
(if (null? l)
#f
(let* ((rrs (car l))
(rr-type (cadddr rrs)))
(if (eq? (message-type soa) rr-type)
(let* ((rdata (cadddr (cdr rrs))))
(parse-mf-time-value? (list-ref rdata 6)))
(loop (cdr l)))))))
;; Set the ttl of lines without one...
(define (set-ttl rrlist soa-ttl)
(map (lambda (e)
(let ((ttl (cadr e)))
(if (and ttl
(< soa-ttl ttl))
e
(cons (car e) (cons soa-ttl (cddr e))))))
rrlist))
;; The main parser algorithm:
;; --------------------------
;; Create a list of lexems and parse the lexems into resource-record-data:
;; TYPE: string x dnsd-options -> list-of-resourec-records
(define (parse-mf file dnsd-options)
(and-let* ((lex-list (lex-masterfile file dnsd-options))
(lines (parse-mf-lex->lines lex-list))
(res (parse-mf-lexem-list lines "." "" #f dnsd-options))
(class (get-message-class res))
(res (set-message-class res class))
(soa-ttl (get-soa-ttl res))
(res (set-ttl res soa-ttl))
(res (map (lambda (e) (parse-mf-create-rr e)) res)))
;; Check if there is a line with an error:
(fold-right (lambda (e l) (if (and e l) (cons e l) #f)) '() res)))

41
scheme/dnsd/masterfile.l
View File

@ -1,41 +0,0 @@
; --------------------
; --- masterfile.l ---
; --------------------
; A SIlex configuration file for masterfiles.
; For more information about SILex visit: http://www.iro.umontreal.ca/~dube/
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
dchars [^\n();@ ] ;; last two chars are space and tabulator
space [ ] ;; space and tabulator
%%
{space} (yycontinue)
\n 'newline
\n{space} 'blank-newline
\; (let loop ((c (yygetc)))
(cond
((eq? 'eof c) 'eof)
((char=? #\newline c)
(begin
(yyungetc)
(yycontinue)))
(else (loop (yygetc)))))
\( 'left-par
\) 'right-par
(\$)ORIGIN 'origin
(\$)INCLUDE 'include
(\$)GENERATE 'generate
(\$)TTL 'ttl
\@ 'origin-ref
{dchars}* yytext
<<EOF>> 'eof
<<ERROR>> (error (yygetc))

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

File diff suppressed because it is too large Load Diff

214
scheme/dnsd/options.scm
View File

@ -1,214 +0,0 @@
; ---------------------
; --- DNSD-Options ---
; ---------------------
; Options for DNS-Server based on the RFCs: 1034 / 1035
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; The format and style of the option procedures is the same as seen
; in the SUNet HTTPD & FTPD - Files
(define-record-type dnsd-options :dnsd-options
(really-make-dnsd-options
port dir nameservers use-axfr use-cache cleanup-interval retry-interval
use-db use-recursion rec-timeout socket-timeout socket-max-tries
max-connections blacklist-time blacklist-value use-pre/post debug-mode)
dnsd-options?
(port dnsd-options-port set-dnsd-options-port!)
(dir dnsd-options-dir set-dnsd-options-dir!)
(nameservers dnsd-options-nameservers set-dnsd-options-nameservers!)
(use-axfr dnsd-options-use-axfr? set-dnsd-options-use-axfr?!)
(use-cache dnsd-options-use-cache? set-dnsd-options-use-cache?!)
(cleanup-interval dnsd-options-cleanup-interval set-dnsd-options-cleanup-interval!)
(retry-interval dnsd-options-retry-interval set-dnsd-options-retry-interval!)
(use-db dnsd-options-use-db? set-dnsd-options-use-db?!)
(use-recursion dnsd-options-use-recursion? set-dnsd-options-use-recursion?!)
(rec-timeout dnsd-options-rec-timeout set-dnsd-options-rec-timeout!)
(socket-timeout dnsd-options-socket-timeout set-dnsd-options-socket-timeout!)
(socket-max-tries dnsd-options-socket-max-tries set-dnsd-options-socket-max-tries!)
(max-connections dnsd-options-max-connections set-dnsd-options-max-connections!)
(blacklist-time dnsd-options-blacklist-time set-dnsd-options-blacklist-time!)
(blacklist-value dnsd-options-blacklist-value set-dnsd-options-blacklist-value!)
(use-pre/post dnsd-options-use-pre/post set-dnsd-options-use-pre/post!)
(debug-mode dnsd-options-debug-mode set-dnsd-options-debug-mode!))
(define (make-default-dnsd-options)
(really-make-dnsd-options
53 ; Port to listen
"./" ; Path to the zone & option files.
'() ; Use the default SBELT-Servers
; Example-list: (list "192.168.2.1" "193.159.170.187" "192.36.148.17")
; or (dns-find-nameserver-list) ; SBELT-Nameserver(s) for recursion.
#t ; Toggles sending AXFR-responses
#t ; Toggles the use of the cache
(* 60 60) ; Cache garbage-collect interval in seconds
(* 60 60) ; Min. time-val (sec) to reload a zone
#t ; If #f don't use the db.
#t ; If #f don't use recursion.
10 ; Timeout (sec) for recursion.
2 ; Timeout (sec) for a query (resolver interface).
3 ; Max. tries on a socket (resolver interface).
25 ; Max. concurrent connections for UDP and TCP.
(* 60 30) ; How long will a blacklist entry be valid?
5 ; How often must a NS be bad to be ignored.
#f ; Don't use pre- and post-processing by default.
#f)) ; Print debug-options to syslog.
(define (copy-dnsd-options options)
(really-make-dnsd-options (dnsd-options-port options)
(dnsd-options-dir options)
(dnsd-options-nameservers options)
(dnsd-options-use-axfr? options)
(dnsd-options-use-cache? options)
(dnsd-options-cleanup-interval options)
(dnsd-options-retry-interval options)
(dnsd-options-use-db? options)
(dnsd-options-use-recursion? options)
(dnsd-options-rec-timeout options)
(dnsd-options-socket-timeout options)
(dnsd-options-socket-max-tries options)
(dnsd-options-max-connections options)
(dnsd-options-blacklist-time options)
(dnsd-options-blacklist-value options)
(dnsd-options-use-pre/post options)
(dnsd-options-debug-mode options)))
(define (make-dnsd-options-transformer set-option!)
(lambda (new-value . stuff)
(let ((new-options (if (not (null? stuff))
(copy-dnsd-options (car stuff))
(make-default-dnsd-options))))
(set-option! new-options new-value)
new-options)))
(define with-port
(make-dnsd-options-transformer set-dnsd-options-port!))
(define with-dir
(make-dnsd-options-transformer set-dnsd-options-dir!))
(define with-nameservers
(make-dnsd-options-transformer set-dnsd-options-nameservers!))
(define with-axfr
(make-dnsd-options-transformer set-dnsd-options-use-axfr?!))
(define with-cache
(make-dnsd-options-transformer set-dnsd-options-use-cache?!))
(define with-cleanup-interval
(make-dnsd-options-transformer set-dnsd-options-cleanup-interval!))
(define with-retry-interval
(make-dnsd-options-transformer set-dnsd-options-retry-interval!))
(define with-db
(make-dnsd-options-transformer set-dnsd-options-use-db?!))
(define with-recursion
(make-dnsd-options-transformer set-dnsd-options-use-recursion?!))
(define with-rec-timeout
(make-dnsd-options-transformer set-dnsd-options-rec-timeout!))
(define with-socket-timeout
(make-dnsd-options-transformer set-dnsd-options-socket-timeout!))
(define with-socket-max-tries
(make-dnsd-options-transformer set-dnsd-options-socket-max-tries!))
(define with-max-connections
(make-dnsd-options-transformer set-dnsd-options-max-connections!))
(define with-blacklist-time
(make-dnsd-options-transformer set-dnsd-options-blacklist-time!))
(define with-blacklist-value
(make-dnsd-options-transformer set-dnsd-options-blacklist-value!))
(define with-use-pre/post
(make-dnsd-options-transformer set-dnsd-options-use-pre/post!))
(define with-debug-mode
(make-dnsd-options-transformer set-dnsd-options-debug-mode!))
(define (make-dnsd-options . stuff)
(let loop ((options (make-default-dnsd-options))
(stuff stuff))
(if (null? stuff)
options
(let* ((transformer (car stuff))
(value (cadr stuff)))
(loop (transformer value options)
(cddr stuff))))))
(define (make-options-from-list o-list options)
(if (eq? (car o-list) 'options)
(begin
(for-each
(lambda (e)
(let ((id (car e))
(value (cadr e)))
(case id
((dir)
(if (string? value)
(set-dnsd-options-dir! options value)
(error "Bad option argument.")))
((nameservers)
(if (list? value)
(set-dnsd-options-nameservers! options value)
(error "Bad option argument.")))
((use-axfr)
(if (boolean? value)
(set-dnsd-options-use-axfr?! options value)
(error "Bad option argument.")))
((use-cache)
(if (boolean? value)
(set-dnsd-options-use-cache?! options value)
(error "Bad option argument.")))
((cleanup-interval)
(if (and (number? value) (<= 10 value))
(set-dnsd-options-cleanup-interval! options value)
(error "Bad option argument.")))
((retry-interval)
(if (and (number? value) (<= 10 value))
(set-dnsd-options-retry-interval! options value)
(error "Bad option argument.")))
((use-db)
(if (boolean? value)
(set-dnsd-options-use-db?! options value)
(error "Bad option argument.")))
((use-recursion)
(if (boolean? value)
(set-dnsd-options-use-recursion?! options value)
(error "Bad option argument.")))
((rec-timeout)
(if (and (number? value) (<= 1 value))
(set-dnsd-options-rec-timeout! options value)
(error "Bad options argument.")))
((socket-timeout)
(if (and (number? value) (<= 1 value) (> 13 value))
(set-dnsd-options-socket-timeout! options value)
(error "Bad options argument.")))
((socket-max-tries)
(if (and (number? value) (<= 1 value) (> 13 value))
(set-dnsd-options-socket-max-tries! options value)
(error "Bad options argument.")))
((max-connections)
(if (and (number? value) (<= 1 value))
(set-dnsd-options-max-connections! options value)
(error "Bad options argument.")))
((blacklist-time)
(if (and (number? value) (<= 60 value))
(set-dnsd-options-blacklist-time! options value)
(error "Bad options argument.")))
((blacklist-value)
(if (and (number? value) (<= 1 value))
(set-dnsd-options-blacklist-value! options value)
(error "Bad options argument.")))
((use-pre/post)
(if (boolean? value)
(set-dnsd-options-use-pre/post! options value)
(error "Bad options argument.")))
((debug-mode)
(if (boolean? value)
(set-dnsd-options-debug-mode! options value)
(error "Bad options argument.")))
(else (error "Bad option.")))))
(cdr o-list))
options)
(error "Not an option list.")))

753
scheme/dnsd/resolver.scm
View File

@ -1,753 +0,0 @@
; ----------------
; --- Resolver ---
; ----------------
; A DNS-Server based on the RFCs: 1034 / 1035
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Interface:
; ----------
;(dnsd-ask-resolver-rec message protocol dnsd-options)
;(dnsd-ask-resolver-direct message list-of-nameservers protocol dnsd-options)
;; The modified send-receive-message socket-interface from dns.scm:
;; ----------------------------------------------------------------
;; Delete the given element(s) from the list:
;; TYPE: list x list -> list
(define (delete-list elems list)
(cond
((null? elems) list)
((null? list) '())
(else (delete-list (cdr elems) (delete (car elems) list)))))
;; dnsd wants the message, not the dns-error codes.
(define (dnsd-acceptable? reply query)
(if (not (= (header-id (message-header reply))
(header-id (message-header query))))
(error "send-receive-message: Bad reply-ID from server.")))
(define (dnsd-send-receive-message-tcp nameserver query dnsd-options)
(send-receive-message-tcp-int nameserver query dnsd-acceptable? dnsd-options))
(define (send-receive-message-tcp-int nameservers query accept? dnsd-options)
(receive
(reply hit-ns other-nss)
(let* ((sockets (map (lambda (nameserver)
(let ((sock (create-socket protocol-family/internet
socket-type/stream))
(addr (internet-address->socket-address
nameserver 53)))
;; Ignore return value and select unconditionally later
(with-fatal-error-handler*
(lambda (condition decline) #f)
(lambda ()
(connect-socket-no-wait sock addr) sock))))
nameservers))
(nameservers (let loop ((sockets sockets)
(nss nameservers))
(cond
((or (null? sockets) (null? nss)) '())
((socket? (car sockets))
(cons (car nss) (loop (cdr sockets) (cdr nss))))
(else (loop (cdr sockets) (cdr nss))))))
(sockets (filter socket? sockets))
(ws (map socket:outport sockets))
(wport-nameserver-alist (map cons ws nameservers))
(wport-socket-alist (map cons ws sockets)))
(with-fatal-error-handler*
(lambda (condition decline)
(for-each close-socket sockets)
decline)
(lambda ()
(dynamic-wind
(lambda () 'nothing-to-be-done-before)
(lambda ()
(let loop-port-channels ((tried-channels '())
(number-tries 1))
;; No channels left to try?
(if (or (null? (delete-list tried-channels ws))
(= (length tried-channels) (length ws))
(>= number-tries
(dnsd-options-socket-max-tries dnsd-options)))
(values query #f nameservers)
(let ((ready
(apply select-ports
(dnsd-options-socket-timeout dnsd-options)
ws)))
(let loop-ready-channels ((ready-channels ready))
(if (null? ready-channels)
(loop-port-channels (append tried-channels ready)
(+ number-tries 1))
(let* ((w (car ready-channels))
(hit-ns
(cdr (assoc w wport-nameserver-alist)))
(sock (cdr (assoc w wport-socket-alist))))
(if (not (connect-socket-successful? sock))
(loop-ready-channels (cdr ready-channels))
(let ((query-string (list->string
(add-size-tag
(message-source query))))
(r (socket:inport sock)))
(with-fatal-error-handler*
(lambda (condition decline)
(loop-ready-channels (cdr ready-channels)))
(lambda ()
(display query-string w)
(force-output w)
(let ((a (read-char r))
(b (read-char r)))
(let ((len (octet-pair->number a b)))
(let ((s (read-string len r)))
(if (and (not (= 0 (string-length s)))
(not (= len (string-length s))))
(error 'unexpected-eof-from-server))
(values (parse (string->list s)) hit-ns
(delete hit-ns nameservers))))))))))))))))
(lambda () (for-each close-socket sockets))))))
(accept? reply query)
(values reply hit-ns other-nss)))
(define (dnsd-send-receive-message-udp nameserver query dnsd-options)
(send-receive-message-udp-int nameserver query dnsd-acceptable? dnsd-options))
(define (send-receive-message-udp-int nameservers query accept? dnsd-options)
(receive
(reply hit-ns other-nss)
(let* ((sockets (map (lambda (nameserver)
(let ((sock (create-socket protocol-family/internet
socket-type/datagram))
(addr (internet-address->socket-address
nameserver 53)))
(connect-socket sock addr)
sock))
nameservers))
(rs (map socket:inport sockets))
(ws (map socket:outport sockets)))
(with-fatal-error-handler*
(lambda (condition decline)
(for-each close-socket sockets)
decline)
(lambda ()
(dynamic-wind
(lambda () 'nothing-to-be-done-before)
(lambda ()
(let ((query-string (list->string (message-source query)))
(rsv (list->vector rs))
(rport-nameserver-alist (map cons rs nameservers))
(rport-socket-alist (map cons rs sockets)))
(for-each (lambda (w) (display query-string w)) ws)
(for-each force-output ws)
(let loop-port-channels ((tried-channels '())
(number-tries 1))
(let ((rs-new (delete-list tried-channels rs)))
(if (or (null? rs-new)
(>= number-tries (dnsd-options-socket-max-tries dnsd-options))
(= (length tried-channels) (length rs)))
(values query #f nameservers)
(let ((ready (apply select-ports
(dnsd-options-socket-timeout dnsd-options)
rs-new)))
(let loop-ready-channels ((ready-channels ready))
(if (null? ready-channels)
(loop-port-channels (append tried-channels ready)
(+ number-tries 1))
(let* ((r (car ready-channels))
(hit-ns (cdr (assoc r rport-nameserver-alist))))
(if (not (connect-socket-successful?
(cdr (assoc r rport-socket-alist))))
(loop-ready-channels (cdr ready-channels))
;; 512 is the maximum udp-message size:
(let ((answer (string->list (read-string/partial 512 r))))
(if (null? answer)
(loop-ready-channels (cdr ready-channels))
(values (parse answer) hit-ns
(delete hit-ns nameservers))))))))))))))
(lambda () (for-each close-socket sockets))))))
(accept? reply query)
(if (flags-truncated? (header-flags (message-header reply)))
(send-receive-message-tcp-int nameservers query accept?)
(values reply hit-ns other-nss))))
(define (dnsd-send-receive-message nameservers query protocol dnsd-options)
((cond
((eq? protocol (network-protocol tcp)) dnsd-send-receive-message-tcp)
((eq? protocol (network-protocol udp)) dnsd-send-receive-message-udp))
nameservers query dnsd-options))
;; Stuff:
;; ------
; Filter a list of rrs of the given type:
; TYPE: list-of-rrs -> list-of-rrs
(define (filter-rr-type type list)
(filter (lambda (e) (eq? (resource-record-type e) type)) list))
;; Randomize a list (needs srfi-1 & srfi-27):
;; TYPE: list -> list
(define (shake-list l)
(define (shake-list-int l res)
(if (null? l)
res
(let ((random-value (random-integer (length l))))
(shake-list-int
(append (take l random-value) (drop l (+ 1 random-value)))
(cons (list-ref l random-value) res)))))
(shake-list-int l '()))
;; Check a message for its response-code:
;; --------------------------------------
;; RCODE-0-Message? (Error-Free)
;; TYPE: message -> boolean
(define (rcode-0-reply? msg)
(eq? 'dns-no-error (flags-response-code (header-flags (message-header msg)))))
;; RCODE-3-Message? (Name-Error (does not exist))
;; TYPE: message -> boolean
(define (rcode-3-reply? msg)
(eq? 'dns-name-error (flags-response-code
(header-flags (message-header msg)))))
;; RCODE-2-Message? Server-Failure
;; TYPE: message -> boolean
(define (rcode-2-reply? msg)
(eq? 'dns-server-failure (flags-response-code
(header-flags (message-header msg)))))
;; RCODE-4-Message? Not Implemented
;; TYPE: message -> boolean
(define (rcode-4-reply? msg)
(eq? 'dns-not-implemented (flags-response-code
(header-flags (message-header msg)))))
;; RCODE-5-Message? (Refused to answer query.)
;; TYPE: message -> boolean
(define (rcode-5-reply? msg)
(eq? 'dns-refused (flags-response-code (header-flags (message-header msg)))))
;; Are there just CNAMEs in the answer-section of a reply?
;; TYPE message -> boolean
(define (cname-answer? msg)
(let ((cnames (fold-right
(lambda (e b)
(or (eq? (message-type cname) (resource-record-type e)) b))
#f (message-answers msg)))
(other (fold-right
(lambda (e b)
(or (not (eq? (message-type cname)
(resource-record-type e))) b))
#f (message-answers msg))))
(if other #f cnames)))
;; Interpreting the results of dbi-lookup-rec - Zone found, but not the name.
;; TYPE res-list-of-db-lookup-rec -> boolean
(define (no-entry? res-l)
(and (null? (car res-l)) (null? (cadr res-l))
(null? (caddr res-l)) (cadddr res-l)))
;; Is the query a cname-question?
;; TYPE: message -> boolean
(define (cname-question? msg)
(eq? (message-type cname) (question-type (car (message-questions msg)))))
;; Create a reply from the internally found (db or cache) information.
;; NOTE: This function is part of the exported functions.
;; TYPE: message x res-list-of-db-lookup-rec x dnsd-options -> message
(define (make-response message r-list dnsd-options)
(let* ((use-recursion? (dnsd-options-use-recursion? dnsd-options))
(error-code (if (no-entry? r-list) 'dns-name-error 'dns-no-error))
(msg-header (message-header message))
(msg-flags (header-flags msg-header))
(anli (car r-list))
(auli (cadr r-list))
(adli (caddr r-list))
(aufl (cadddr r-list)))
(make-message
(make-header (header-id msg-header)
(make-flags
'response
(flags-opcode msg-flags)
aufl
(flags-truncated? msg-flags)
(flags-recursion-desired? msg-flags)
use-recursion?
(flags-zero msg-flags)
error-code)
(header-question-count msg-header)
(length anli)
(length auli)
(length adli))
(message-questions message)
anli auli adli '())))
;; Increment the answer-section (for adding a cname)
;; TYPE: message -> message
(define (msg-inc-answers msg-header)
(let ((msg-flags (header-flags msg-header)))
(make-header (header-id msg-header)
msg-flags
(header-question-count msg-header)
(+ 1 (header-answer-count msg-header))
(header-nameserver-count msg-header)
(header-additional-count msg-header))))
;; Change the type of a question to (message-type cname)
;; TYPE: messag -> message
(define (msg->cname-msg msg)
(let ((q (car (message-questions msg))))
(make-message (message-header msg)
(list (make-question (question-name q)
(message-type cname)
(question-class q)))
(message-answers msg)
(message-nameservers msg)
(message-additionals msg) '())))
;; Assignment procs:
;; -----------------
;; Set the recursion-aviable flag:
;; TYPE: message x boolean -> message
(define (msg-set-recursion-aviable! msg bool)
(set-flags-recursion-available! (header-flags (message-header msg)) bool))
;; Set the response-code of a message:
;; NOTE: This function is part of the exported functions.
;; TYPE: message x rcode -> message
(define (msg-set-rcode! msg code)
(let ((rcode (case code
((0) 'dns-no-error)
((1) 'dns-format-error)
((2) 'dns-server-failure)
((3) 'dns-name-error)
((4) 'dns-not-implemented)
((5) 'dns-refused)
(else code))))
(set-flags-response-code! (header-flags (message-header msg)) rcode)))
;; Direct lookup:
;; --------------
;; Direct lookup of a query asking the given Nameserves:
;; TYPE: message x list-of-address32 tcp/udp x dnsd-options -> message
(define (dnsd-lookup-direct msg ns-list proto dnsd-options)
(receive (msg hit-ip other-ips)
(dnsd-send-receive-message
ns-list
(make-message (message-header msg) (message-questions msg)
(message-answers msg) (message-nameservers msg)
(message-additionals msg) (mc-message->octets msg))
proto dnsd-options)
(if hit-ip
msg
(begin
(dnsd-log (syslog-level info)
"dnsd-direct-lookup. Nameservers ~S not reachable."
ns-list)
(error "dnsd-direct-lookup. No NS reachable.")))))
;; Stuff for recursive lookup:
;; ---------------------------
;; SBELT:
;; ------
;; Fallback nameserver for recursive lookup. This is the default value which
;; can be changed by the dnsd-options:
(define *sbelt*
(list ;(ip-string->address32 "192.5.5.241")
(ip-string->address32 "192.36.148.17")
(ip-string->address32 "192.5.5.241")))
;; Some nameserver IPs:
;; --------------------
;; 192.36.148.17 i.root-servers.net. (for .)
;; 192.5.5.241 f.root-server.net. (for .)
;; 192.5.6.30 A.GTLD-SERVERS.NET. (for .com.
;; 193.159.170.187 deNIC-NS (for .de.)
;; Record-Type for additional information needed by the lookup:
;; cnames is a list of all seen CNAMES to avoid CNAME-loops.
;; ips is a list of used NS-IPs for the query.
;; timestamp is the creation-time of the context and used for timeouts.
(define-record-type context :context
(really-make-context cnames ips timestamp)
context?
(cnames get-context-cnames set-context-cnames!)
(ips get-context-ips set-context-ips!)
(timestamp get-context-timestamp))
;; Makes the lookup-context for a given query.
;; TYPE: message -> context
(define (make-context message)
(really-make-context
(list (question-name (car (message-questions message))))
'()
(time)))
;; Add a name to the context.
;; TYPE: context x string -> context
(define (update-context-cnames! context value)
(set-context-cnames! context (cons value (get-context-cnames context)))
context)
;; Add a IP to the context.
;; TYPE: context x address32 -> context
(define (update-context-ips! context value)
(set-context-ips! context (cons value (get-context-ips context)))
context)
;; Search the SLIST for the best 'nearest' nameserver to query for a message.
;; The nearest server is the server for the domain with the most matching labels
;; seen from the root: 1) www.example.com. 2) example.com. 3) com. 4) . 5) SBELT
;; TYPE: message x dnsd-options -> list-of-nameserver-ips x zone-name-of-ns
(define (search-for-ns-ips msg dnsd-options)
(let* ((q (car (message-questions msg)))
(name (question-name q))
(class (question-class q)))
(let loop ((name name))
(let ((ip-list (dnsd-slist-lookup
(make-simple-query-message name (message-type ns) class)
dnsd-options)))
(if ip-list
(values ip-list name #f)
(if (string=? "." name)
(let* ((sbelt-string (dnsd-options-nameservers dnsd-options))
(sbelt (map ip-string->address32 sbelt-string)))
(if (null? sbelt)
(values *sbelt* name #t)
(values sbelt name #t)))
(loop (cut-name name))))))))
;; Ask the message to some NS from the SLIST. Keep track which NSs were already
;; contacted for the given query in 'context'.
;; TYPE: message x udp/tcp x dnsd-options x context
;; -> message-answer x context x nearest-NS-string x address32
(define (ask-nameservers msg protocol dnsd-options context)
(receive
(ip-list name sbelt?)
(search-for-ns-ips msg dnsd-options)
;; Use only IPs which haven't been tried jet
(let ((good-ips (filter (lambda (e)
(not (fold-right
(lambda (e1 b)
(or b (= e1 e)))
#f (get-context-ips context))))
ip-list)))
;; randomize the list for some simple load-balancing...
(let loop ((good-ips (shake-list good-ips)))
(if (null? good-ips)
(error "ask-nameservers: Tried all known Nameservers.")
(receive
(msg hit-ip other-ips)
(dnsd-send-receive-message
(list (car good-ips))
(make-message (message-header msg) (message-questions msg)
(message-answers msg) (message-nameservers msg)
(message-additionals msg) (mc-message->octets msg))
protocol dnsd-options)
(if hit-ip
(values msg (update-context-ips! context hit-ip)
name hit-ip)
(begin
(if (not sbelt?) (dnsd-blacklist! (car good-ips)))
(loop (cdr good-ips))))))))))
;; Some responses contain nameserver-names but sadly not their IPs.
;; This function searches for those IPs, add the results to the
;; cache and restarts the recursive lookup.
;; TYPE: message x udp/tcp x list-of-rrs x dnsd-options -> unspecific
(define (lookup-nameserver-ips msg protocol ns-rrs dnsd-options)
(let* ((ns-names (map (lambda (e) (resource-record-data-ns-name
(resource-record-data e))) ns-rrs))
(ns-queries (map (lambda (e)
;;(display-debug "Looking for this names: " e)
(make-simple-query-message
e (message-type a)
(question-class
(car (message-questions msg))))) ns-names))
; ;; This step might take a while :-(
; (answers (map (lambda (e)
; (dnsd-ask-resolver-rec e protocol dnsd-options))
; ns-queries))
;; Concurrent lookup of the IPs:
(ch-list (map
(lambda (msg)
(let ((ch-res (make-channel)))
(fork-thread
(lambda ()
(sync (send-rv
ch-res
;; Use dnsd-ask-r... because of the 'good'
;; return value.
(dnsd-ask-resolver-rec msg protocol
dnsd-options)))))
ch-res))
ns-queries))
;; Wait for all results:
(answers (map (lambda (ch) (sync (receive-rv ch))) ch-list))
(good-answers (filter (lambda (e) (rcode-0-reply? e)) answers))
(ip-rrs (map (lambda (msg) (filter-rr-type (message-type a)
(message-answers msg)))
good-answers))
(flat-ns-list (fold-right (lambda (e l) (append e l)) '() ip-rrs)))
(if (null? flat-ns-list)
#f ;TODO: Do we need a strategy to avoid loops if we don't find NS?
(dnsd-slist-update!
(make-message (message-header msg) (message-questions msg)
'() ns-rrs flat-ns-list '())))))
;; Restart dnsd-get-info-int with question-name changed to the cname.
;; TYPE: query-message x response-message x udp/tcp x dnsd-options x context
;; -> respones-message
(define (cname-lookup msg res protocol dnsd-options context)
(let* ((q (car (message-questions msg)))
(msg-name (question-name q))
(cname-rr (fold-right
(lambda (e a)
(if a a
(if (and (eq? (message-type cname)
(resource-record-type e))
(string-ci=? (resource-record-name e)
msg-name))
e a)))
#f (message-answers res)))
(cname (resource-record-data-cname-name
(resource-record-data cname-rr)))
(found-loop? (fold-right (lambda (e b)
(or (string-ci=? cname e) b))
#f (get-context-cnames context))))
(if found-loop? ; Check for CNAME-Loop
(begin ;;(display-debug "Found a CNAME-loop. Aborting!")
(error "Found a CNAME-loop. Aborting recursive lookup."))
(let* ((new-msg (make-message (message-header msg)
(list (make-question cname
(question-type q)
(question-class q)))
'() '() '() '()))
(res (dnsd-get-info-int new-msg protocol dnsd-options
;; Keep timout, allow all IPs again...
(really-make-context
(cons cname (get-context-cnames context))
'()
(get-context-timestamp context))))
(new-res (make-message (msg-inc-answers (message-header res))
(message-questions msg)
(cons cname-rr (message-answers res))
(message-nameservers res)
(message-additionals res) '())))
new-res))))
;; Recursive Lookup as seen in RFC 1034:
;; -------------------------------------
;; 1) Check local information and (if present) return it to the client.
;; 2) Search for server(s) to ask. Wait for a response.
;; 3) Analyze the response:
;; 3.1 cache answers or name error.
;; 3.2 cache delegation info to other servers. Retry.
;; 3.3 if the response shows a CNAME and that is not the
;; answer itself, cache the CNAME, change the SNAME to the
;; canonical name in the CNAME RR and go to step 1.
;; 3.4 servers failure etc.: delete server from cache. Retry.
;; Start the recursive lookup and initialize the first context-list
;; with the name of the question (to avoid CNAME-Loops).
;; TYPE: message x udp/tcp x dnsd-options -> message
(define (dnsd-get-information message protocol dnsd-options)
(dnsd-get-info-int message protocol dnsd-options (make-context message)))
;; TYPE: message x udp/tcp x dnsd-options x context -> message
(define (dnsd-get-info-int message protocol dnsd-options context)
; 1) Search local information:
(let* ((use-cache? (dnsd-options-use-cache? dnsd-options))
(local-res (if use-cache? (dnsd-cache-lookup? message) #f)))
;; Timeout?
(if (> (- (time) (get-context-timestamp context))
(dnsd-options-rec-timeout dnsd-options))
(error "dnsd-get-info-int: Global timeout.")
(if local-res (make-response message local-res dnsd-options)
;; 2) Could be: Search for the best nameserver to ask.
;; Now it's: Ask all servers concurrent and take
;; the first result.
(receive
(rec-res context followed-name hit-ip)
(ask-nameservers message protocol dnsd-options context)
;; 3) Analyze the response:
(let* ((ns-rrs (filter-rr-type (message-type ns)
(message-nameservers rec-res)))
(a-rrs (filter-rr-type (message-type a)
(message-additionals rec-res))))
(cond
;; 3.4) Bad answer: Some NS are to 'lazy' to return cnames
;; and return RCODE 5 instead. The NS of sourceforge.net.
;; are a good bad example.
((rcode-5-reply? rec-res)
(if (not (cname-question? rec-res))
(let ((cname-query
(dnsd-get-information (msg->cname-msg message)
protocol dnsd-options)))
(if (cname-answer? cname-query)
(cname-lookup message cname-query protocol
dnsd-options context)
(begin (dnsd-blacklist! hit-ip)
rec-res)))
(begin (dnsd-blacklist! hit-ip) rec-res)))
;; 3.4) Try again with other servers.
((rcode-2-reply? rec-res)
(dnsd-blacklist! hit-ip)
(dnsd-get-info-int message protocol dnsd-options context))
((rcode-4-reply? rec-res)
(dnsd-blacklist! hit-ip
(dnsd-options-blacklist-value dnsd-options))
(dnsd-get-info-int message protocol dnsd-options context))
(else
;; A "good" reply.
(dnsd-blacklist-unlist! hit-ip dnsd-options)
(cond
;; 3.1) Found a name-error.
((rcode-3-reply? rec-res)
(dnsd-cache-update! rec-res) rec-res)
;; 3.4) Whatever error is left... .
((not (rcode-0-reply? rec-res)) rec-res)
;; 3.1) Found an answer.
((not (null? (message-answers rec-res)))
;; 3.3) CNAME?
(if (and (not (cname-question? rec-res))
(cname-answer? rec-res))
(begin
(dnsd-cache-update! (msg->cname-msg rec-res))
;;(display-debug "Starting CNAME Lookup!")
(cname-lookup message rec-res protocol
dnsd-options context))
;; Returning of not-authoritative data
;; may be a bad habbit...
(if (flags-authoritative?
(header-flags (message-header rec-res)))
rec-res
rec-res)))
(else
;; 3.2) Redirection to other Nameservers?
(cond
((null? ns-rrs) rec-res)
((null? a-rrs)
;; Only nameserver resource-records, search for IPs
(lookup-nameserver-ips rec-res protocol
ns-rrs dnsd-options)
(dnsd-get-info-int message protocol dnsd-options context))
(else
(dnsd-slist-update! rec-res)
(dnsd-get-info-int message protocol
dnsd-options context)))))))))))))
;; ---------------------------------
;; --- Server/Resolver-Interface ---
;; ---------------------------------
;; (dnsd-ask-resolver-direct msg nameserver-list protocol dnsd-options)
;; - Ask a specific nameserver (& don't use the SLIST-Interface.)
;; (E.g. for the AXFR-Update algorihms.)
;;
;; (dnsd-ask-resolver-rec msg protocol dnsd-options)
;; - Ask indirect (and recursive) via the SLIST-Cache.
;; TYPE: message x upd/tcp x dnsd-options -> message
(define (dnsd-ask-resolver-rec msg proto dnsd-options)
(set-message-source! msg (mc-message->octets msg))
(let ((ch-timeout (make-channel))
(ch-res (make-channel)))
(fork-thread
(lambda ()
(sleep (* 1000 (dnsd-options-rec-timeout dnsd-options)))
(sync (send-rv ch-timeout #t))))
(fork-thread
(lambda ()
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level debug)
"Error during recursive lookup.")
(msg-set-rcode! msg 2)
msg)
(lambda ()
(sync (send-rv ch-res (dnsd-get-information msg
proto dnsd-options)))))))
(sync
(choose
(wrap (receive-rv ch-timeout)
(lambda (ignore)
(dnsd-log (syslog-level info)
"Timeout during recursive lookup. Current value is ~Ds"
(dnsd-options-rec-timeout dnsd-options))
(msg-set-rcode! msg 2) msg))
(wrap (receive-rv ch-res)
(lambda (value)
value))))))
;; TYPE: message x list-of-address32 x upd/tcp x dnsd-options -> message
(define (dnsd-ask-resolver-direct msg nameservers proto dnsd-options)
(set-message-source! msg (mc-message->octets msg))
(with-fatal-error-handler*
(lambda (condition decline)
(dnsd-log (syslog-level debug)
"Error during direct lookup.")
(msg-set-rcode! msg 2)
msg)
(lambda ()
(dnsd-lookup-direct msg nameservers proto dnsd-options))))

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

@ -1,177 +0,0 @@
; ----------------------------------
; --- Resource-Record-Definition ---
; ----------------------------------
; Wrapper for (make-resource-record ___) from dns.scm:
; * Abstraction of (make-resource-record ___ (make-resource-record-data-* ___))
; * Now for all supported types: (dns-rr-<type> ...)
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Interface:
; (dns-rr-a ...)
; (dns-rr-txt ...)
; etc..
; Abstraction of (make-resource-record ... (make-resource-record-data-* ...))
; Now: (dns-rr-* ...), trying to include data-integrity.
; *** Some stuff ***
(define (make-message-class class)
(cond
((number? class)
(message-class-number->type class))
((symbol? class)
(message-class-symbol->type class))
((message-class? class)
class)
(else #f)))
(define (make-message-type type)
(cond
((number? type)
(message-type-number->type type))
((symbol? type)
(message-type-symbol->type type))
((message-type? type)
type)
(else #f)))
(define (make-address32 ip)
(cond
((address32? ip) ip)
((ip-string? ip)
(ip-string->address32 ip))
(else #f)))
; Nice to know: valid ttls: 0-2147483647
; *02* - (dns-rr-* ...) functions:
; Warning: This functions won't work with any other class than 'IN'!
; TYPES: name x class x ttl x data -> resource-record-record-type or #f
(define (dns-rr-a name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in)))
(a32 (make-address32 data)))
(make-resource-record
name (message-type a)
class ttl
(make-resource-record-data-a a32))))
(define (dns-rr-ns name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in)))
(ns-name (make-fqdn-name data))
(whatever (fqdn? ns-name)))
(make-resource-record
name (message-type ns)
class ttl
(make-resource-record-data-ns ns-name))))
(define (dns-rr-cname name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in)))
(cname-name (make-fqdn-name data))
(whatever (fqdn? cname-name)))
(make-resource-record
name (message-type cname)
class ttl
(make-resource-record-data-cname cname-name))))
(define (dns-rr-soa name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in)))
(mname (make-fqdn-name (car data)))
(whatever (fqdn? mname))
(rname (make-fqdn-name (cadr data)))) ;! what's with fqdn...
(make-resource-record
name (message-type soa)
class ttl
(make-resource-record-data-soa
mname rname
(caddr data)
(cadddr data)
(cadr (cdddr data))
(caddr (cdddr data))
(cadddr (cdddr data))))))
(define (dns-rr-ptr name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in)))
(ptr-name (make-fqdn-name data))
(whatever (fqdn? ptr-name)))
(make-resource-record
name (message-type ptr)
class ttl
(make-resource-record-data-ptr ptr-name))))
(define (dns-rr-hinfo name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in))))
(make-resource-record
name (message-type hinfo)
class ttl
(make-resource-record-data-hinfo data))))
(define (dns-rr-mx name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in)))
(pref (car data))
(whatever (number? pref))
(mx-name (make-fqdn-name (cadr data)))
(whatever (fqdn? mx-name)))
(make-resource-record
name (message-type mx)
class ttl
(make-resource-record-data-mx
pref mx-name))))
(define (dns-rr-txt name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in))))
(make-resource-record
name (message-type txt)
class ttl
(make-resource-record-data-txt data))))
(define (dns-rr-aaaa name class ttl data)
(and-let* ((name (make-fqdn-name name))
(whatever (fqdn? name))
(class (make-message-class class))
(whatever (eq? class (message-class in))))
(make-resource-record
name (message-type aaaa)
class ttl
(make-resource-record-data-aaaa data))))

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

@ -1,105 +0,0 @@
; -----------------------
; --- Read/Write-Lock ---
; -----------------------
; Locks for a DNS-Server based on the RFCs: 1034 / 1035
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Simple locks for the dns-server database. The idea behind this sort of
; lock is to permit multiple threads to read the data secured by the lock.
; If a thread tries to write, it'll block all other access to the data
; and do it's work isolated. (One write to block them all... ;-)
; Interface:
; (make-r/w-lock) : creates an r/w-lock
; (obtain-R/w-lock r/w-lock)
; (obtain-r/W-lock r/w-lock)
; (release-R/w-lock r/w-lock)
; (release-r/W-lock r/w-lock)
; (with-R/w-lock rwlock thunk)
; (with-r/W-lock rwlock thunk)
(define-record-type r/w-lock :r/w-lock
(really-make-r/w-lock write-flag read-count write-lock mutex-lock)
r/w-lock?
(write-flag get-r/w-lock-write-flag set-r/w-lock-write-flag!)
(read-count get-r/w-lock-read-count set-r/w-lock-read-count!)
(write-lock get-r/w-lock-write-lock)
(mutex-lock get-r/w-lock-mutex-lock))
(define (make-r/w-lock)
(really-make-r/w-lock #f 0 (make-lock) (make-lock)))
(define (obtain-R/w-lock r/w-lock)
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
(let loop ()
(obtain-lock mutex-lock)
; Is there is a thread writing?
(if (get-r/w-lock-write-flag r/w-lock)
(begin
(release-lock mutex-lock)
; Just wait for some time and try again...
; TODO?: Do that with locks
(relinquish-timeslice)
(loop))
(begin
(set-r/w-lock-read-count!
r/w-lock
(+ 1 (get-r/w-lock-read-count r/w-lock)))
(release-lock mutex-lock))))))
(define (release-R/w-lock r/w-lock)
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
(obtain-lock mutex-lock)
(set-r/w-lock-read-count!
r/w-lock (- (get-r/w-lock-read-count r/w-lock) 1))
(release-lock mutex-lock)))
(define (obtain-r/W-lock r/w-lock)
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
(write-lock (get-r/w-lock-write-lock r/w-lock)))
; Maybe wait here for another write-thread:
(obtain-lock write-lock)
(let loop ()
(obtain-lock mutex-lock)
(set-r/w-lock-write-flag! r/w-lock #t)
(if (= 0 (get-r/w-lock-read-count r/w-lock))
(release-lock mutex-lock)
(begin
(release-lock mutex-lock)
; Wait until the reads finish...
; TODO?: Do that with locks
(relinquish-timeslice)
(loop))))))
(define (release-r/W-lock r/w-lock)
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
(write-lock (get-r/w-lock-write-lock r/w-lock)))
(obtain-lock mutex-lock)
(set-r/w-lock-write-flag! r/w-lock #f)
(release-lock mutex-lock)
(release-lock write-lock)))
(define (with-R/w-lock rwlock thunk)
(obtain-R/w-lock rwlock)
(let ((value (thunk)))
(release-R/w-lock rwlock)
value))
(define (with-r/W-lock rwlock thunk)
(obtain-r/W-lock rwlock)
(let ((value (thunk)))
(release-r/W-lock rwlock)
value))

83
scheme/dnsd/semaphores.scm
View File

@ -1,83 +0,0 @@
; ----------------------
; --- Semaphore-Lock ---
; ----------------------
; Semaphore-locks for a DNS-Server based on the RFCs: 1034 / 1035
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Wait on the semaphore-lock if the semaphore-counter reaches 0
; Interface:
; (make-semaphore initial-value)
; (set-semaphore! new-value)
; (semaphore-post semaphore)
; (semaphore-wait semaphore)
(define-record-type semaphore :semaphore
(really-make-semaphore value i waiting-list mutex-lock)
semaphore?
(value get-semaphore-value set-semaphore-value!)
(i get-semaphore-counter set-semaphore-counter!)
(waiting-list get-semaphore-waiting set-semaphore-waiting!)
(mutex-lock get-semaphore-lock))
(define (make-semaphore i)
(really-make-semaphore i i '() (make-lock)))
;; Reset the internal semaphore-counter.
(define (set-semaphore! sem new-value)
(if (semaphore? sem)
(begin
(obtain-lock (get-semaphore-lock sem))
(let* ((old-value (get-semaphore-value sem))
(diff (- new-value old-value)))
(set-semaphore-value! sem new-value)
(set-semaphore-counter! sem (+ (get-semaphore-counter sem) diff))
(release-lock (get-semaphore-lock sem))))
(error "Not a semaphore.")))
;; Release a lock, if one is held or add 1 to the counter.
(define (semaphore-post sem)
(if (semaphore? sem)
(begin
(obtain-lock (get-semaphore-lock sem))
(let ((waiting-list (get-semaphore-waiting sem)))
(if (null? waiting-list)
(begin
(set-semaphore-counter! sem (+ 1 (get-semaphore-counter sem)))
(release-lock (get-semaphore-lock sem)))
(let ((locked-thread (car waiting-list)))
(set-semaphore-waiting! sem (cdr waiting-list))
(release-lock locked-thread)
(release-lock (get-semaphore-lock sem))))))
(error "Not a semaphore.")))
;; Wait on the semaphore if the counter is 0
(define (semaphore-wait sem)
(if (semaphore? sem)
(begin
(obtain-lock (get-semaphore-lock sem))
(if (> (get-semaphore-counter sem) 0)
(begin
(set-semaphore-counter! sem (- (get-semaphore-counter sem) 1))
(release-lock (get-semaphore-lock sem)))
(let ((lock (make-lock)))
(set-semaphore-waiting! sem
(cons lock (get-semaphore-waiting sem)))
(obtain-lock lock)
(release-lock (get-semaphore-lock sem))
(obtain-lock lock))))
(error "Not a semaphore.")))

364
scheme/dnsd/slist.scm
View File

@ -1,364 +0,0 @@
; -----------------------
; --- SLIST/Blacklist ---
; -----------------------
; SLIT-Structure for the recursiv lookup algorithm (resolver.scm).
; The Blacklist is used to store 'bad' Nameserver-IPs.
; This file is part of the Scheme Untergrund Networking package
; Copyright (c) 2005/2006 by Norbert Freudemann
; <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.
; Naming-Scheme:
; --------------
; dnsd-slist-...
; dnsd-blacklist-...
;; SLIST-Cache
; The SLIST-Structure as described in RFC1034/1035.
; Lock-Safe Cache-Interface:
; ---------------------------
; (dnsd-slist-clear!) - Removes the whole data.
; (dnsd-slist-clean!) - Removes expired data.
; (dnsd-slist-lookup msg dnsd-options) - Returns nameserver IPs.
; (dnsd-slist-update! msg) - Stores Nameservers & their IPs.
; (dnsd-slist-pretty-print) - Prints the slist.
;; Blacklist:
; An IP-Adress can be blacklisted by bad resolver-results in resolver.scm
; This will cause the increment a blacklist-value. After the value reaches
; a threshold the IP will be ignored for some time (dnsd-options).
;
; After that, the next question for this IP can result in the following:
; - ignore the IP another round for bad answer
; - whitelist the IP for a good answer...
; (A good result will remove any IP from the blacklist.)
; Lock-Safe Cache-Interface:
; ---------------------------
; (dnsd-blacklist! ip . value) - Blacklist a IP.
; (dnsd-blacklist-clean! dnsd-options)
; (dnsd-blacklist-unlist! ip dnsd-options)
; (dnsd-blacklist-clear!)
; (dnsd-blacklist-print)
; Stuff:
; ------
; Filter rrs of the given type:
; TYPE: message-type x list-of-rrs -> list-of-rrs
(define (filter-rr-type type list)
(filter (lambda (e) (eq? (resource-record-type e) type)) list))
(define *debug-info* #f)
; TODO: Do this different:
; Shows the debug-information
(define display-debug
(lambda args
(if *debug-info*
(begin
(display "dnsd: ")
(map (lambda (e) (display e) (display " ")) args)
(newline))
#f)))
; SLIST:
; ------
(define-record-type dnsd-slist :dnsd-slist
(make-dnsd-slist data lock)
dnsd-slist?
(data get-dnsd-slist-data) ; slist-data-record-type
(lock get-dnsd-slist-lock)) ; r/w-lock
(define-record-type slist-data :slist-data
(make-slist-data answer expires)
cache?
(answer slist-data-answer set-slist-data-answer!) ; list-of-rrs
(expires slist-data-expires)) ; expiration time of the data (+ ttl (time))
; Create the slist:
(define *dnsd-slist* (make-dnsd-slist (make-string-table) (make-r/w-lock)))
;; Search for the shortest TTL in the message:
;; TYPE: message -> number or #f
(define (dnsd-slist-find-shortest-ttl msg)
(let loop ((msg msg))
(cond
((dns-message? msg) (loop (dns-message-reply msg)))
((message? msg) (fold-right
(lambda (e m)
(let ((ttl (resource-record-ttl e)))
(if m
(if (<= m ttl) m ttl)
ttl)))
#f (message-additionals msg))))))
;; Make a SLIST-Key from a message:
;; TYPE: message -> key-string
(define (make-slist-key msg)
(let ((question (car (message-questions msg))))
(format #f "~a;~a" (string-downcase (question-name question))
(message-class-name (question-class question)))))
;; Resets the SLIST:
(define (dnsd-slist-clear!)
(with-r/W-lock
(get-dnsd-slist-lock *dnsd-slist*)
(lambda ()
(set! *dnsd-slist* (make-dnsd-slist (make-string-table)
(get-dnsd-slist-lock *dnsd-slist*))))))
;; Removes expired data from the SLIST:
(define (dnsd-slist-clean!)
(with-r/W-lock
(get-dnsd-slist-lock *dnsd-slist*)
(lambda ()
(let ((time (time))
(table (get-dnsd-slist-data *dnsd-slist*)))
(table-walk (lambda (k e)
(if (< time (slist-data-expires e))
#t
(table-set! table k #f)))
table)))))
;; Add the results of the given response to the cache-data
;; a min ttl is given to the NS so that the rec-lookup-algorithm
;; will be able to do it's work properly... .
;; TYPE: message -> unspecific
(define (dnsd-slist-update-ns! msg)
(with-r/W-lock
(get-dnsd-slist-lock *dnsd-slist*)
(lambda ()
(and-let* ((key (make-slist-key msg)))
(let* ((ttl (dnsd-slist-find-shortest-ttl msg))
(min-ttl (if (< ttl 120) 120 ttl))
(expires (+ (time) min-ttl)))
(table-set!
(get-dnsd-slist-data *dnsd-slist*)
key
(make-slist-data (message-additionals msg) expires)))))))
; Take the nameservers & the corresponding IPs from a message and
; (if no entry is present) adds the nameservers to the cache to be looked up
; via the nameserver-zone (found as resource-record name of the servers)
; Some server return nameserver resource records in the answer-section
; others in the additional section.
;; TYPE: message -> unspecific
(define (dnsd-slist-update! msg)
(display-debug "Updating SLIST! Adding a Nameserver.")
(and-let* ((ns-rrs (append (message-answers msg) (message-nameservers msg)))
(additionals (message-additionals msg))
(good-ns-rrs (filter-rr-type (message-type ns) ns-rrs))
(whatever (not (null? good-ns-rrs)))
(good-additionals (filter-rr-type (message-type a) additionals))
(whatever (not (null? good-additionals)))
(class (question-class (car (message-questions msg))))
(nameserver-zone (resource-record-name (car good-ns-rrs)))
(good-ns-rrs (filter (lambda (e)
(string-ci=? nameserver-zone
(resource-record-name e)))
good-ns-rrs))
(nameserver-names (map (lambda (e)
(resource-record-data-ns-name
(resource-record-data e))) good-ns-rrs))
(good-additionals (filter
(lambda (e)
(fold-right
(lambda (name b)
(if b b (string-ci=?
name (resource-record-name e))))
#f nameserver-names))
good-additionals))
(new-msg
(make-message (message-header msg)
(list (make-question nameserver-zone
(message-type ns) class))
good-ns-rrs '() good-additionals '())))
(dnsd-slist-update-ns! new-msg)))
;; Look for the IPs of the nameservers in the cache.
;; TYPE: message -> list-of-address32
(define (dnsd-slist-lookup msg dnsd-options)
;; Look for data in the slist:
(define (dnsd-slist-lookup-int msg)
(let ((lock (get-dnsd-slist-lock *dnsd-slist*)))
(obtain-R/w-lock lock)
(let* ((data (get-dnsd-slist-data *dnsd-slist*))
(key (make-slist-key msg))
(cdata (table-ref data key)))
(if cdata
(if (< (time) (slist-data-expires cdata))
(begin
(let ((res (slist-data-answer cdata)))
(release-R/w-lock lock)
res))
(begin
(release-R/w-lock lock)
(obtain-r/W-lock lock)
(table-set! data key #f)
(release-r/W-lock lock)
#f))
(begin (release-R/w-lock lock) #f)))))
;; ---
(and-let* ((additionals (dnsd-slist-lookup-int msg))
(ns-a-rrs (filter-rr-type (message-type a) additionals))
(ip-list (map (lambda (e) (resource-record-data-a-ip
(resource-record-data e))) ns-a-rrs)))
;; Filter good from blacklisted IPs:
(with-R/w-lock
(get-dnsd-blacklist-lock *blacklist*)
(lambda ()
(filter (lambda (ip)
(let ((element (table-ref (get-dnsd-blacklist-data *blacklist*)
ip)))
(cond
;; IP isn't in the blacklist-table
((not element) #t)
;; The IP hasn't been blacklisted blacklist-value-times
((>= (dnsd-options-blacklist-value dnsd-options)
(cdr element)) #t)
;; Blacklisted longer than blacklist-time-value. Try again.
((<= (+ (dnsd-options-blacklist-time dnsd-options)
(car element))
(time)) #t)
;; Don't use the IP
(else #f))))
ip-list)))))
;; Blacklist:
;; ----------
(define-record-type dnsd-blacklist :dnsd-blacklist
(make-dnsd-blacklist data lock)
dnsd-blacklist?
(data get-dnsd-blacklist-data) ; a integer-table
(lock get-dnsd-blacklist-lock)) ; r/w-lock
(define *blacklist* (make-dnsd-blacklist (make-integer-table) (make-r/w-lock)))
;; Add a IP to the blacklist:
;; TYPE: address32 -> unspecific
(define (dnsd-blacklist! ip . value)
(with-r/W-lock
(get-dnsd-blacklist-lock *blacklist*)
(lambda ()
(let* ((table (get-dnsd-blacklist-data *blacklist*))
(element (table-ref table ip))
(value (if (null? value)
1
(car value))))
(if element
(table-set! table ip (cons (time) (+ value (cdr element))))
(table-set! table ip (cons (time) value)))))))
;; Removes the given ip from the list:
;; TYPE address32 -> unspecific
(define (dnsd-blacklist-unlist! ip dnsd-options)
(with-r/W-lock
(get-dnsd-blacklist-lock *blacklist*)
(lambda ()
(let ((blacklist (get-dnsd-blacklist-data *blacklist*)))
(if (and (table-ref blacklist ip)
(< (cdr (table-ref blacklist ip))
(dnsd-options-blacklist-value dnsd-options)))
(table-set! blacklist ip #f)
#f)))))
;; Remove all blacklisted IPs:
(define (dnsd-blacklist-clear!)
(with-r/W-lock
(get-dnsd-blacklist-lock *blacklist*)
(lambda ()
(set! *blacklist* (make-dnsd-blacklist
(make-integer-table)
(get-dnsd-blacklist-lock *blacklist*))))))
;; Deprecated:
;; Remove old entries:
; (define (dnsd-blacklist-clean! dnsd-options)
; (with-r/W-lock
; (get-dnsd-blacklist-lock *blacklist*)
; (lambda ()
; (table-walk
; (lambda (key element)
; (if (< (dnsd-options-blacklist-time dnsd-options)
; (- (time) (car element)))
; (table-set! (get-dnsd-blacklist-data *blacklist*) key #f)))
; (get-dnsd-blacklist-data *blacklist*)))))
;; Display SLIST / Blacklist:
;; --------------------------
;; Display the blacklisted IPs:
(define (dnsd-blacklist-print)
(with-R/w-lock
(get-dnsd-blacklist-lock *blacklist*)
(lambda ()
(let ((data (get-dnsd-blacklist-data *blacklist*))
(current-time (time)))
(display "DNSD-Blacklist:\n")
(display "---------------\n")
(table-walk
(lambda (key element)
(display "\nIP: ")
(display (address32->ip-string key))
(display " with blacklist-value: ")
(display (cdr element))
(display " [with age ")
(display (- current-time (car element)))
(display "s.]")
(newline))
data)))))
;; Display the SLIST:
(define (dnsd-slist-pretty-print)
(with-R/w-lock
(get-dnsd-slist-lock *dnsd-slist*)
(lambda ()
(let ((data (get-dnsd-slist-data *dnsd-slist*)))
(display "DNSD-SLIST:\n")
(display "-----------\n")
(table-walk
(lambda (k e)
(let ((slist-data (slist-data-answer e)))
(display "\n*Zone: ")
(display k)(newline)
(display " ---------\n")
(display " Expires in: ")
(display (- (slist-data-expires e) (time)))
(display " seconds.\n")
(display " \n Nameservers-Section:\n\n")
(map (lambda (y) (pretty-print-dns-message y))
slist-data)))
data)))))

3
scheme/ftpd/ftpd.scm
View File

@ -346,6 +346,7 @@
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
@ -374,8 +375,6 @@
(log (syslog-level debug) "socket: ~S" socket-string)
(set-ftp-socket-options! socket)
(dynamic-wind
(lambda () 'fick-dich-ins-knie)
(lambda ()

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

@ -103,7 +103,7 @@
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
; why did we had (string-suffix? "-nph" prog) here?
(search (http-url-search (request-url req))) ; Compute the
(search (http-url-query (request-url req))) ; Compute the
(argv (if (and search (not (string-index search #\=))) ; argv list.
(split-and-decode-search-spec search)
'()))
@ -124,25 +124,29 @@
(case (file-not-executable? filename)
((search-denied permission)
(make-error-response (status-code forbidden) req
"Permission denied."))
"No permission to search directory."))
((no-directory nonexistent)
(make-error-response (status-code not-found) req
"File or directory doesn't exist."))
(make-error-response (status-code not-found) req))
(else
(if nph?
(cgi-make-nph-response (run/port* doit))
(cgi-make-response (run/port* doit) path req)))))
(else
(make-error-response (status-code method-not-allowed) req request-method))))))
((string=? request-method "HEAD")
(make-error-response (status-code method-not-allowed) req "GET, POST"))
(else
(make-error-response (status-code not-implemented) req))))))
(define (split-and-decode-search-spec s)
(let recur ((i 0))
(cond
((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
((string-index s #\+ i) => (lambda (j) (cons (unescape s i j)
(recur (+ j 1)))))
(else (list (unescape-uri s i (string-length s)))))))
(else (list (unescape s i (string-length s)))))))
;;; Compute the CGI scripts' process environment by adding the standard CGI
@ -171,14 +175,14 @@
(headers (request-headers req))
;; Compute the $PATH_INFO and $PATH_TRANSLATED strings.
(path-info (uri-path->uri path-suffix)) ; No encode or .. check.
(path-info (string-join path-suffix "/")) ; No encode or .. check.
(path-translated (path-list->file-name path-info bin-dir))
;; Compute the $SCRIPT_PATH string.
(url-path (http-url-path (request-url req)))
(script-path (take (- (length url-path) (length path-suffix))
url-path))
(script-name (uri-path->uri script-path)))
(script-name (string-join script-path "/")))
(receive (rhost rport)
(socket-address->internet-address raddr)
@ -201,7 +205,7 @@
,@request-invariant-cgi-env ; Stuff that never changes (see cgi-handler).
,@(cond ((http-url-search (request-url req)) =>
,@(cond ((http-url-query (request-url req)) =>
(lambda (srch) `(("QUERY_STRING" . ,srch))))
(else '()))
@ -259,9 +263,8 @@
(request-method req))
(if loc
(if (uri-has-protocol? (string-trim loc))
(make-error-response (status-code moved-perm) req
loc loc)
(if (absolute-url? (url-string->http-url (string-trim loc)))
(make-error-response (status-code moved-perm) req loc)
(make-redirect-response (string-trim loc)))
;; Send the response header back to the client
(make-response ;code message seconds mime extras body
@ -283,11 +286,6 @@
(make-writer-body (lambda (out options)
(copy-inport->outport script-port out)))))
(define (uri-has-protocol? loc)
(receive (proto path search frag)
(parse-uri loc)
(if proto #t #f)))
(define (extract-status-code-and-text status req)
(with-fatal-error-handler*
(lambda (c d)

115
scheme/httpd/core.scm
View File

@ -2,10 +2,6 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 2000-2002 by Martin Gasbichler.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
@ -17,12 +13,13 @@
;;; a complete server, you need to define request handlers (see below) --
;;; they determine how requests are to be handled.
;;;
;;; The RFC detailing the HTTP 1.0 protocol, RFC 1945, can be found at
;;; http://www.w3.org/Protocols/rfc1945/rfc1945
;;; See RFC 2616 for the specification of the HTTP/1.1 protocol.
;;;
;;; The server is compatible with previous versions of HTTP in the way
;;; described in RFC 2616 19.6. See RFC 1945 for the specification of
;;; HTTP/1.0 and 0.9.
(define server/protocol "HTTP/1.0")
(define (httpd options)
(let ((port (httpd-options-port options))
(root-dir (httpd-options-root-directory options))
@ -154,23 +151,23 @@
(values #f
(apply make-error-response (status-code bad-request)
#f ; No request yet.
"Request parsing error -- report to client maintainer."
(condition-stuff c))))
((not (and (exception? c)
(eq? (exception-reason c)
(enum exception os-error))))
;; try to send bug report to client
(eq? (exception-reason c);;?? ->
(enum exception os-error))));;?? ->
;;which cases is this supposed to catch excactly? broken
;;connection to client? If so, does it work?
(values #f
(apply make-error-response (status-code internal-error)
#f ; don't know
"Internal error occurred while processing request"
c)))
(else
(decline))))
(lambda ()
(let ((initial-req (parse-http-request sock options)))
(let redirect-loop ((req initial-req))
(check-major-http-version initial-req)
(check-host-header initial-req)
(let redirect-loop ((req initial-req))
(let response-loop ((response ((httpd-options-request-handler options)
(http-url-path (request-url req))
req)))
@ -181,7 +178,7 @@
(socket:inport sock))))
((nph-response? response)
(values req response))
((eq? (response-code response) (status-code redirect))
((eq? (response-code response) (status-code redirect));internal redirect
(redirect-loop (redirect-request req response sock options)))
(else
(values req response)))))))))
@ -193,6 +190,9 @@
options)
)))))
;;; REDIRECT-REQUEST relies on that nothing is read out from SOCKET.
(define (redirect-request req response socket options)
(let* ((new-location-uri (redirect-body-location (response-body response)))
(url (with-fatal-error-handler*
@ -206,7 +206,7 @@
;; (future) NOTE: With this, a redirection may change the
;; protocol in use (currently, the server only supports one of
;; it). This might be inapplicable.
(parse-http-servers-url-fragment new-location-uri socket options)))))
(url-string->http-url new-location-uri)))))
(make-request "GET"
new-location-uri
@ -215,18 +215,7 @@
'() ; no rfc822 headers
(request-socket req))))
;;;; HTTP request parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; This code provides procedures to read requests from an input
;;;; port.
;;; Read and parse an http request from INPORT.
;;;
;;; Note: this parser parses the URI into an http URL record. If the URI
;;; isn't an http URL, the parser fails. This may not be right. There's
;;; nothing in the http protocol to prevent you from passing a non-http
;;; URI -- what this would mean, however, is not clear. Like so much of
;;; the Web, the protocols are redundant, underconstrained, and ill-specified.
(define (parse-http-request sock options)
(let ((line (read-crlf-line (socket:inport sock))))
@ -250,46 +239,15 @@
((3) (parse-http-version (caddr elts)))
(else (fatal-syntax-error "Bad Request Line."))))
(meth (car elts))
(uri-string (cadr elts))
(url (parse-http-servers-url-fragment uri-string sock options))
(request-uri (cadr elts))
(url (url-string->http-url request-uri))
(headers (if (equal? version '(0 . 9))
'()
(read-rfc822-headers (socket:inport sock)))))
(make-request meth uri-string url version headers sock)))))
;;; Parse the URL, but if it begins without the "http://host:port"
;;; prefix, interpolate one from SOCKET. It would be sleazier but
;;; faster if we just computed the default host and port at
;;; server-startup time, instead of on every request.
;;; REDIRECT-REQUEST relys on that nothing is read out from SOCKET.
(define (parse-http-servers-url-fragment uri-string socket options)
(receive (scheme path search frag-id) (parse-uri uri-string)
(if frag-id ; Can't have a #frag part.
(fatal-syntax-error "HTTP URL contains illegal #<fragment> suffix."
uri-string)
(if scheme
(if (string-ci=? scheme "http") ; Better be an http url.
(parse-http-url path search #f)
(fatal-syntax-error "Non-HTTP URL" uri-string))
;; Interpolate the server struct from our net connection.
(if (and (pair? path) (string=? (car path) ""))
(let* ((addr (socket-local-address socket))
(local-name (or (httpd-options-fqdn options)
(socket-address->fqdn addr)))
(portnum (or (httpd-options-reported-port options)
(my-reported-port addr))))
(make-http-url (make-server #f #f
local-name
(number->string portnum))
(map unescape-uri (cdr path)) ; Skip initial /.
search
#f))
(fatal-syntax-error "Path fragment must begin with slash"
uri-string))))))
(with-fatal-error-handler
(lambda (c decline)
(fatal-syntax-error "Illegal RFC 822 field syntax of request headers"))
(read-rfc822-headers (socket:inport sock))))))
(make-request meth request-uri url version headers sock)))))
(define parse-http-version
@ -303,6 +261,19 @@
(lose vstring))))))
;;; check whether the request's major HTTP version is greater than the
;;; server's major HTTP version; if so, send 505 (Version not supported).
(define (check-major-http-version req)
(if (> (car (request-version req)) (car http-version))
(http-error (status-code version-not-supp) req)))
(define (check-host-header req)
(if (not (version< (request-version req) '(1 . 1)))
(or (get-header (request-headers req) 'host)
(http-error (status-code bad-request) req "Missing Host header"))))
;;; Split string into a list of whitespace-separated strings.
;;; This could have been trivially defined in scsh as (field-splitter " \t\n")
;;; but I hand-coded it because it's short, and I didn't want invoke the
@ -322,7 +293,7 @@
(else '()))))
(define (send-http-headers response port)
(display server/protocol port)
(display (version->string http-version) port)
(write-char #\space port)
(display (status-code-number (response-code response)) port)
(write-char #\space port)
@ -334,7 +305,8 @@
(send-http-header-fields
(list (cons 'server (string-append "Scheme Untergrund " sunet-version-identifier))
(cons 'content-type (response-mime response))
(cons 'date (rfc822-time->string (response-seconds response))))
(cons 'date (rfc822-time->string (response-seconds response)))
(cons 'connection "close"))
port)
(send-http-header-fields (response-extras response) port)
@ -358,7 +330,8 @@
(else
(if (not (v0.9-request? request))
(send-http-headers response output-port))
(if (not (string=? (request-method request) "HEAD"))
(if (not (or (string=? (request-method request) "HEAD")
(no-body? (response-body response)))) ;; response messages which MUST NOT include a message-body
(display-http-body (response-body response) input-port output-port options))
(http-log request (response-code response)))))
@ -370,7 +343,3 @@
(write-crlf port))
headers))
(define (my-reported-port addr)
(receive (ip-addr portnum) (socket-address->internet-address addr)
portnum))

19
scheme/httpd/error.scm
View File

@ -2,7 +2,6 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
@ -23,19 +22,37 @@
(define http-error? (condition-predicate 'http-error))
;; See make-error-response for what you have to stuff into args for
;; each status-code. (All http-errors will be caught by the top-level
;; error-handler of process-toplevel-request, and will be turned into
;; calls of make-error-response).
(define (http-error status-code req . args)
(apply signal 'http-error status-code req args))
;;; Syntax error condition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Scheme 48 has a "syntax error" error condition, but it isn't an error
;;; condition! It's a warning condition. I don't understand this.
;;; We define a *fatal* syntax error here for the parsers to use.
;; fatal-syntax-error isn't really a different type of error - it's
;; just an abbreviated notation:
;; (fatal-syntax-error msg irritants)
;; is equivalent to
;; (http-error (status-code bad-request) #f msg irritants)
;; -> use fatal-syntax-error where the client request cannot be parsed
;; because of bad syntax
(define-condition-type 'fatal-syntax-error '(error))
(define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
;; as with http-errors fatal-syntax-errors will be caught by the
;; top-level error-handler of process-toplevel-request and turned into
;; calls of make-error-response
(define (fatal-syntax-error msg . irritants)
(apply signal 'fatal-syntax-error msg irritants))

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

@ -211,7 +211,7 @@
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
(define (make-rooted-file-path-response root file-path file-serve-response req options)
(if (http-url-search (request-url req))
(if (http-url-query (request-url req))
(make-error-response (status-code bad-request) req
"Indexed search not provided for this URL.")
(cond ((dotdot-check root file-path) =>
@ -252,17 +252,24 @@
(send-file-response fname info req options))
((directory) ; Send back a redirection "foo" -> "foo/"
(let* ((url (request-url req))
(url-string (http-url->url-string url))
(location-prefix
(if (absolute-url? url)
url-string
(string-append
"http://" (get-socket-host-string req) url-string))) ;we don't support virtual hosts yet!
(location (string-append location-prefix "/")))
(make-error-response
(status-code moved-perm) req
(string-append (request-uri req) "/")
(string-append (http-url->string (request-url req))
"/")))
(status-code moved-perm) req location)))
(else (make-error-response (status-code forbidden) req)))))
(else
((string=? request-method "POST")
(make-error-response (status-code method-not-allowed) req
request-method))))))
"GET, HEAD"))
(else
(make-error-response (status-code not-implemented) req))))))
(define (directory-index-serve-response fname file-path req options)
(file-serve-response (string-append fname "index.html") file-path req options))
@ -361,7 +368,7 @@
((directory) "[DIR ]")
(else "[????]"))))
(if icon-name
(emit-tag port 'img
(emit-empty-tag port 'img
(cons 'src icon-name)
(cons 'alt tag-name))
(display tag-name port))
@ -415,7 +422,8 @@
(file-directory-options-back-icon-url options))
(blank-icon
(file-directory-options-blank-icon-url options)))
(with-tag port html ()
(emit-prolog port)
(with-tag port html (xmlnsdecl-attr)
(let ((title (string-append "Index of /"
(string-join file-path "/"))))
(with-tag port head ()
@ -425,16 +433,16 @@
(with-tag port pre ()
(if blank-icon
(display "[ ]" port)
(emit-tag port 'img
(emit-empty-tag port 'img
(cons 'src blank-icon)
(cons 'alt " ")))
(write-string "Name " port)
(write-string "Last modified " port)
(write-string "Size " port)
(write-string "Description" port)
(emit-tag port 'hr)
(emit-empty-tag port 'hr)
(if back-icon
(emit-tag port 'img
(emit-empty-tag port 'img
(cons 'src back-icon)
(cons 'alt "[UP ]"))
(display "[UP ]" port))
@ -444,11 +452,14 @@
(write-string "Parent directory" port))
(write-crlf port)))
(let ((n-files (directory-index req fname port options)))
(emit-tag port 'hr)
(emit-empty-tag port 'hr)
(format port "~d files" n-files))))))))))))
(else
(make-error-response (status-code method-not-allowed) req
request-method)))))
((string=? request-method "POST")
(make-error-response (status-code method-not-allowed) req
"GET, HEAD"))
(else
(make-error-response (status-code not-implemented) req)))))
(define (index-or-directory-serve-response fname file-path req options)
(let ((index-fname (string-append fname "index.html")))

195
scheme/httpd/handler-lib.scm Normal file
View File

@ -0,0 +1,195 @@
;;; A library of procs for request handlers.
;;; This file is part of the Scheme Untergrund Networking package.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Reading in the message body of a request.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read in the message body of an HTTP message and return it as a string.
;;;
;;; READ-MESSAGE-BODY handles ordinary message bodies as well as
;;; message bodies to which the transfer coding "chunked" has been
;;; applied.
;;;
;;; Note: all request handlers should use READ-MESSAGE-BODY, and should not
;;; read in message bodies by themselves: READ-MESSAGE-BODY implements
;;; the correct order in which a message body's length is determined.
;;; (See RFC 2616, 4.4 for precedence of Transfer-encoding header over Content-length header.)
(define (read-message-body req)
(let ((inport (socket:inport (request-socket req))))
(if (chunked-transfer-coding? req)
(read-chunked-body inport)
(read-ordinary-body inport req))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Reading in ordinary bodies (no transfer coding applied)
;;; Read in the message body, return it as a string.
(define (read-ordinary-body inport req)
(let* ((body-length (get-body-length-from-content-length req)) ;make sure we have a valid Content-length header in request
(maybe-body (read-string body-length inport)))
(or maybe-body
(fatal-syntax-error "EOF while reading in message body"))))
;;Get length of the request's message body from Content-length header or
;;throw fatal-syntax-error if no such header
(define (get-body-length-from-content-length req)
(let
;;try to get field value of first Content-length header (RFC 2616 allows only one Content-length: header)
((maybe-length (get-numeric-field-value req 'content-length)))
(or maybe-length
(fatal-syntax-error "No Content-Length header in request"))))
;; GET-NUMERIC-FIELD-VALUE
;; generalized function to get a field value of the form 1*DIGIT
;; req is a request record, field-name a symbol
;; check wether a header-field with name field-name is contained in req;
;; if not, return #f,
;; else, take the first such header field and check wether its field-content conforms to
;; field-content = *LWS 1*DIGIT *LWS
;; if so, return digit as a number
(define (get-numeric-field-value req field-name)
(let
;;try to get first "field-name" header
((field-content (get-header (request-headers req) field-name)))
(if field-content ;; request contained "field-name" header
(let ;;see * below
((field-value (string->number (string-trim-both field-content char-set:blank)))) ;;char-set:blank = Space + Tab = LWS from RFC2616 after folding
(if (and field-value (>= field-value 0)) ;;yes, field value contained only digits.
field-value
(fatal-syntax-error
(format #f
"~A header contained only whitespace, or characters other than digits, or whitespace between digits"
field-name))))
#f)))
;;* RFC 2616, 4.2: The field-content does not include any leading or
;;trailing LWS: linear white space occurring before the first
;;non-whitespace character of the field-value or after the last
;;non-whitespace character of the field-value. Such leading or
;;trailing LWS MAY be removed without changing the semantics of the
;;field value.
;;(probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Decoding chunked entity bodies: "chunked transfer-coding"
;;; Is the request's entity body sent in chunked transfer-encoding?
;;; (See RFC 2616, 14.41 and 3.6 for syntax and semantics of Transfer-Encoding header.)
(define (chunked-transfer-coding? req)
(let ((field-value (get-header (request-headers req) 'transfer-encoding)))
(if (not field-value)
#f
; the field value is a comma-separated list of transfer-codings (3.6),
; extract the last transfer-coding in the list
(let* ((reversed-field-value (string-reverse field-value))
(index ; does the list contain more than one element?
(string-contains reversed-field-value " ,"))
(last-transfer-coding
(if index
(string-trim (string-reverse (string-take reversed-field-value index)))
(string-trim field-value))))
; the first token of the (extracted last) transfer-coding must be "chunked" to indicate chunked transfer coding
(string-prefix? "chunked" last-transfer-coding)))))
;;; Read in the chunked entity body, return it as a string.
;;; (See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies.)
(define (read-chunked-body inport)
(let read-chunks ((chunk-size (get-chunk-size inport))
(res ""))
(if (= 0 chunk-size) ;last-chunk
(begin (discard-trailer inport); see comment *1
res)
(let ((maybe-chunk-data (read-string chunk-size inport)))
(if maybe-chunk-data
(begin (discard-line-terminator inport)
(read-chunks (get-chunk-size inport) (string-append res maybe-chunk-data)))
(fatal-syntax-error "EOF while reading in chunk-data in chunked entity body"))))))
;comment *1:
;
;This is were we don't achieve conditional compliance: we ought to read
;in the entity-headers in the trailer and incorporate them into the
;request record. Within our current scheme (where reading in the
;entity-body is the request-handlers job - while the request-handler
;is only called _after_ the request record has been built) this is not
;possible.
;
;Note that in their current state (04/2005) the handlers actually
;disregard most request headers anyway (even the request headers
;parsed into the request record).
;
;Alternatively we could check the request for a Trailer header and
;respond with 500 if we find one. Problem here: the clients "SHOULD
;include a Trailer header field in a message using chunked
;transfer-coding with a non-empty trailer" (14.40) - they are not
;obliged to! So even if we check for a Trailer header we may still
;silently disregard a trailer.
;;;Read in a chunk-size line within a chunked entity body; return the chunk-size as an integer.
;;; (See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies.)
(define (get-chunk-size inport)
(let ((chunk-size-line (read-crlf-line inport)))
(if (eof-object? chunk-size-line)
(fatal-syntax-error "EOF while reading in chunk-size in chunked entity body")
(let* ((chunk-extensions-index (string-contains chunk-size-line "; "))
(hex-string (if chunk-extensions-index
(string-take chunk-size-line chunk-extensions-index)
chunk-size-line))
(chunk-size-int (string->number (string-trim-both hex-string char-set:blank) 16)))
(if (and chunk-size-int (>= chunk-size-int 0)) ; yes, chunk-size contained only hex chars
chunk-size-int
(fatal-syntax-error "Chunk-size within chunked entity body is incorrect or syntactically faulty"))))))
(define (discard-trailer inport)
(with-fatal-error-handler
(lambda (c decline)
(fatal-syntax-error "Illegal RFC 822 field syntax within trailer of entity message body"))
(read-rfc822-headers inport)))
(define (discard-line-terminator inport)
(read-char inport) (read-char inport)) ;;assuming the line terminator is CRLF as required by RFC 2616
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Misc
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; interpolate host info from our request's net connection.
;; return string. Example: "134.2.12.72:7777"
(define (get-socket-host-string req)
(let ((addr (socket-local-address (request-socket req))))
(call-with-values
(lambda ()(socket-address->internet-address addr))
(lambda (ipaddr portnum)
(string-append (format-internet-host-address ipaddr) ":" (number->string portnum))))))

20
scheme/httpd/handlers.scm
View File

@ -23,7 +23,7 @@
;;; lookup to determine how to implement a given operation on a particular
;;; path.
;;;
;;; The REQUEST is a request record, as defined in httpd-core.scm, containing
;;; The REQUEST is a request record, as defined in request.scm, containing
;;; the details of the client request.
;; general request handler combinator:
@ -48,20 +48,14 @@
(make-predicate-handler
(lambda (path req)
;; we expect only one host-header-field
(let ((body (string-trim (get-header (request-headers req) 'host))))
(or (string-ci=? hostname body)
(string-prefix-ci? (string-append hostname ":") body))))
(let ((maybe-val (get-header (request-headers req) 'host)))
(if maybe-val
(let ((val (string-trim maybe-val)))
(or (string-ci=? hostname val)
(string-prefix-ci? (string-append hostname ":") val)))
(http-error (status-code bad-request) req "No Host: header"))))
handler default-handler))
(define (get-header headers tag)
(cond
((assq tag headers) => cdr)
(else
(http-error (status-code bad-request) #f
(string-append "Request did not contain "
(symbol->string tag)
" header")))))
;; selects handler according to path-prefix
;; if path-prefix matches, handler is called without the path-prefix
(define (make-path-prefix-handler path-prefix handler default-handler)

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

@ -117,7 +117,7 @@
((list? parse-info) ; it's an info path
(lambda (url)
(values parse-info
(unescape-uri (http-url-search url)))))
(unescape (http-url-query url)))))
(else
(let ((info-path
((infix-splitter ":")
@ -128,7 +128,7 @@
"")))))
(lambda (url)
(values info-path
(unescape-uri (http-url-search url))))))))
(unescape (http-url-query url))))))))
(make-reference
(cond
((procedure? reference) reference)
@ -163,19 +163,21 @@
'()
(make-writer-body
(lambda (out options)
(emit-prolog out)
(receive (find-entry node-name) (parse-info-url (request-url req))
(display-node node-name
(file-finder find-entry)
(referencer make-reference (request-url req) out)
icon-name
out))
(with-tag out address ()
(with-tag out address ();; this is outside the html element?
(write-string address out)))))))
(else
((or (string=? request-method "HEAD")
(string=? request-method "POST"))
(make-error-response (status-code method-not-allowed) req
request-method)))))))
"GET"))
(else
(make-error-response (status-code not-implemented) req)))))))
(define split-header-line
(let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)")))
@ -232,7 +234,7 @@
(string-append "(" file ")" node))))
(define (display-icon file alt out)
(emit-tag out 'img
(emit-empty-tag out 'img
(cons 'src file)
(cons 'alt alt)
(cons 'align "bottom")))
@ -243,7 +245,7 @@
(let ((file (or node-file file)))
(with-tag out a ((href (make-reference
old-entry
(escape-uri (unparse-node-name file node)))))
(escape-not-unreserved-chars (unparse-node-name file node)))))
(if (and (not (null? maybe-icon))
(car maybe-icon))
(display-icon (car maybe-icon) (cadr maybe-icon) out))
@ -280,18 +282,18 @@
(emit-title out (string-append "Info Node: "
(unparse-node-name file node)))
(with-tag out h1 ()
(emit-tag out 'img
(emit-empty-tag out 'img
(cons 'src (icon-name 'info))
(cons 'alt "Info Node")
(cons 'align 'bottom))
(write-string (unparse-node-name file node) out))
(emit-tag out 'hr)
(emit-empty-tag out 'hr)
(maybe-display-header next (icon-name 'next) "[Next]")
(maybe-display-header previous (icon-name 'previous) "[Previous]")
(maybe-display-header up (icon-name 'up) "[Up]")
(if (or next previous up)
(emit-tag out 'hr)))
(emit-empty-tag out 'hr)))
;; Text
@ -438,7 +440,7 @@
(receive (port file-header node-header up-header prev-header next-header)
(find-node file node find-file)
(with-tag out html ()
(with-tag out html (xmlnsdecl-attr)
(with-tag out head ()
(display-title file node-header up-header
prev-header next-header

20
scheme/httpd/logging.scm
View File

@ -123,8 +123,8 @@
(socket-remote-address (request-socket req)))
(format-internet-host-address host-address))
(request-method req) ; request method
(uri-path->uri
(http-url-path (request-url req))) ; requested file
(http-url-path->path-string
(http-url-path (request-url req))) ; requested file (escaped as it was in original request)
(version->string (request-version req)) ; protocol version
(status-code-number status-code)
23 ; filesize (unknown)
@ -154,7 +154,7 @@
(with-errno-handler*
(lambda (errno packet)
(http-syslog (syslog-level warning)
"[httpd] Warning: An error occurred while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
"[httpd] Warning: An error occured while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
log-file
(car packet))
(make-null-output-port))
@ -169,11 +169,21 @@
(or (maybe-dns-lookup remote-ip) "-")
(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date)) ; +0000 as we don't know
(string-join (list request-type
(string-append "/" requested-file)
requested-file
protocol))
; Unfortunately, we first split the request line into
; method/request-type etc. and put it together here.
; Files conform to CLF are expected to print the original line.
; --> Shouldn't be a problem: the original request
; line is reconstructed almost completely:
; requested-file (i.e. http-url->url-string url) is
; exactly the original Request_URI (apart from
; multiple slashes, which are thrown away),
; request-type and protocol are the original.
; --> Only number of slashes in Request_URI and
; whitespace between parts of Request-Line can differ.
(or http-code "-")
(or filesize "-")
(if (string? referer) (string-trim referer) '-)
@ -187,7 +197,7 @@
(or (with-fatal-error-handler*
(lambda (condition decline)
(http-syslog (syslog-level debug)
"An error occurred while resolving IP ~A: ~A"
"An error occured while resolving IP ~A: ~A"
remote-ip condition)
remote-ip)
(lambda ()

5
scheme/httpd/request.scm
View File

@ -1,7 +1,7 @@
;;;; HTTP request
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1996 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
@ -10,7 +10,7 @@
(define-record-type request :request
(make-request method uri url version headers socket)
request?
(method request-method) ; A string such as "GET", "PUT", etc.
(method request-method) ; A string such as "GET", "POST", etc.
(uri request-uri) ; The escaped URI string as read from request line.
(url request-url) ; An http URL record (see url.scm).
(version request-version) ; A (major . minor) integer pair.
@ -26,6 +26,7 @@
(request-version req)
(request-headers req)
(request-socket req))))
;;; A http protocol version is an integer pair: (major . minor).
(define (version< v1 v2)

287
scheme/httpd/response.scm
View File

@ -1,10 +1,10 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define http-version '(1 . 1));server's HTTP-version is only hardcoded here!
(define-record-type http-response :http-response
(make-response code message seconds mime extras body)
response?
@ -21,6 +21,12 @@
;;representing the field value.
(body response-body));; message-body
;;TODO: mime shouldn't be a field in http-response, because it needn't be present for
;;responses which don't include a message-body.
;;Instead treat mime-type like any other header.
;;(Not urgent, as RFC 2616 doesn't prohibit presence of Content-Type header field
;;in body-less responses).
;; This is mainly for nph-... CGI scripts.
;; This means that the body will output the entire MIME message, not
;; just the part after the headers.
@ -40,6 +46,15 @@
writer-body?
(proc writer-body-proc))
;; the concept of http-reader-writer-body doesn't work: status-line
;; and headers of the response (i.e. the whole http-response record)
;; have to be built _before_ we have seen the entity-body of the
;; request. (Not until display-http-body hands over the iport to
;; reader-writer-body the entity-body can be read in). If the
;; entity-body is erroneous or if we encounter a server internal error
;; while reading in the entity-body we are not able to send an
;; appropriate response. (At that point of time we already sent
;; status-line and response-headers!)
(define-record-type http-reader-writer-body :http-reader-writer-body
(make-reader-writer-body proc)
reader-writer-body?
@ -50,6 +65,14 @@
redirect-body?
(location redirect-body-location))
;; type for responses which MUST NOT include a body (101, 204, 304)
(define-enumerated-type no-body :no-body
no-body?
no-body-elements
no-body-name
no-body-index
(none))
(define (display-http-body body iport oport options)
(cond
((writer-body? body)
@ -66,36 +89,56 @@
(number status-code-number)
(message status-code-message)
(
(continue 100 "Continue")
(switch-protocol 101 "Switching Protocols")
(ok 200 "OK")
(created 201 "Created")
(accepted 202 "Accepted")
(prov-info 203 "Provisional Information")
(non-author-info 203 "Non-Authoritative Information")
(no-content 204 "No Content")
(reset-content 205 "Reset Content")
(partial-content 206 "Partial Content")
(mult-choice 300 "Multiple Choices")
(moved-perm 301 "Moved Permanently")
(moved-temp 302 "Moved Temporarily")
(method 303 "Method (obsolete)")
(found 302 "Found");;use 303 or 307 for unambiguity;
;;use 302 for compatibility with
;;pre-1.1-clients
(see-other 303 "See other");;client is expected to
;;perform a GET on new URI
(not-mod 304 "Not Modified")
(use-proxy 305 "Use Proxy")
(temp-redirect 307 "Temporary Redirect");;analogous to "302
;;Moved Temporarily"
;;in RFC1945
(bad-request 400 "Bad Request")
(unauthorized 401 "Unauthorized")
(payment-req 402 "Payment Required")
(payment-required 402 "Payment Required")
(forbidden 403 "Forbidden")
(not-found 404 "Not Found")
(method-not-allowed 405 "Method Not Allowed")
(none-acceptable 406 "None Acceptable")
(not-acceptable 406 "Not Acceptable")
(proxy-auth-required 407 "Proxy Authentication Required")
(timeout 408 "Request Timeout")
(conflict 409 "Conflict")
(gone 410 "Gone")
(gone 410 "Gone")
(length-required 411 "Length Required")
(precon-failed 412 "Precondition Failed")
(req-ent-too-large 413 "Request Entity Too Large")
(req-uri-too-large 414 "Request URI Too Large")
(unsupp-media-type 415 "Unsupported Media Type")
(req-range-not-sat 416 "Requested Range Not Satisfiable")
(expectation-failed 417 "Expectation Failed")
(internal-error 500 "Internal Server Error")
(not-implemented 501 "Not Implemented")
(bad-gateway 502 "Bad Gateway")
(service-unavailable 503 "Service Unavailable")
(gateway-timeout 504 "Gateway Timeout")
(version-not-supp 505 "HTTP Version Not Supported")
(redirect -301 "Internal redirect")))
(define (name->status-code name)
@ -122,147 +165,183 @@
(else
(loop (+ i 1)))))))
;;; (make-error-response status-code req [message . extras])
;;; (make-error-response status-code req [extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; As a special case, request REQ is allowed to be #f, meaning we haven't
;;; even had a chance to parse and construct the request. This is only used
;;; for 400 BAD-REQUEST error report.
;;; even had a chance to parse and construct the request. This can be the case for
;;; internal-error, bad-request, (possibly bad-gateway and ...?)
(define (make-error-response code req . args)
(let* ((message (and (pair? args) (car args)))
(extras (if (pair? args) (cdr args) '()))
(generic-title (lambda (port)
(title-html port
(status-code-message code))))
(send-message (lambda (port)
(if message
(format port "<BR>~%Further Information: ~A<BR>~%" message))))
(close-html (lambda (port)
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
(write-string "</BODY>\n" port)))
(create-response
(lambda (headers writer-proc)
(make-response code
#f
(time)
"text/html"
headers
(make-writer-body writer-proc)))))
(define (make-error-response code req . extras)
(let*
;;catch server internal errors coming off by calls of make-error-response with too few arguments
((assert (lambda (n)
(if (< (length extras) n)
(make-error-response (status-code internal-error) req
"Too few arguments to make-error-response"))))
(generic-title (lambda (port)
(title-html port
(status-code-message code))))
(close-html (lambda (port args)
(if (not (null? args))
(format port "<br/>~%Further Information:~%"))
(for-each (lambda (x) (format port "<br/>~%~A~%" x)) args)
(format port "</p>~%</body>~%</html>~%")))
(create-response
(lambda (headers body)
(make-response code
#f
(time)
"text/html"
headers
body)))
(create-writer-body-response
(lambda (headers writer-proc)
(create-response headers (make-writer-body writer-proc))))
(create-no-body-response
(lambda (headers)
(create-response headers (no-body none)))))
(cond
;; This error response requires two args: message is the new URI: field,
;; and the first EXTRA is the older Location: field.
((or (eq? code (status-code moved-temp))
(eq? code (status-code moved-perm)))
(create-response
(list (cons 'uri message)
(cons 'location (car extras)))
;;this response requires one arg:
;;the value of the Upgrade field header,
;;which must be a string listing the protocols which are being switched
;;for example "HTTP/2.0, IRC/6.9"
((eq? code (status-code switch-protocol));; server currently doesn't have ability to switch protocols
(assert 1)
(create-no-body-response
(list (cons 'upgrade (car extras))
(cons 'connection "upgrade")))) ;; need this, because Upgrade header field only applies to immediate connection
((eq? code (status-code no-content))
(create-no-body-response '()))
;; This error response requires one arg:
;; the value of the Location field header,
;; which must be a single absolute URI
((or (eq? code (status-code found));302
(eq? code (status-code see-other));303
(eq? code (status-code temp-redirect));307
(eq? code (status-code moved-perm)));301
(assert 1)
(create-writer-body-response
(list (cons 'location (car extras)))
(lambda (port options)
(title-html port "Document moved")
(format port
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
(if (eq? code (status-code moved-temp))
"temporarily"
"permanently")
message)
(close-html port))))
"The requested resource has moved ~A to a <a href=\"~A\">new location</a>.~%"
(if (eq? code (status-code moved-perm))
"permanently"
"temporarily")
(car extras))
(close-html port (cdr extras)))))
((eq? code (status-code bad-request))
(create-response
((eq? code (status-code not-mod))
(create-no-body-response '())) ;;see RCF 2616 10.3.5: this is only a valid answer if the server never sends
;;any of the headers Expires, Cache-Control, Vary for this resource
((eq? code (status-code bad-request))
(create-writer-body-response
'()
(lambda (port options)
(generic-title port)
(write-string "<P>Client sent a query that this server could not understand.\n"
port)
(send-message port)
(close-html port))))
(lambda (port options)
(generic-title port)
(format port "The request the client sent could not be understood by this server due to malformed syntax.~% Report to client maintainer.~%")
(close-html port extras))))
;; This error response requires one arg:
;; the value of the Allow field header,
;; which must be a string listing the valid methods for the requested resource
;; Ex.: "GET, HEAD, POST"
((eq? code (status-code method-not-allowed))
(create-response
'()
(assert 1)
(create-writer-body-response
(list (cons 'allow (car extras)))
(lambda (port options)
(generic-title port)
(write-string "<P>Method not allowed.\n" port)
(send-message port)
(close-html port))))
(format port "The method ~A is not allowed on the requested resource ~A.~%"
(request-method req) (http-url->url-string (request-url req)))
(close-html port (cdr extras)))))
;; This error response requires one arg:
;; the value of the WWW-Authenticate header field,
;; which must be a challenge (as described in RFC 2617)
((eq? code (status-code unauthorized))
(create-response
(list (cons 'WWW-Authenticate message)) ; Vas is das?
;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47
;; message should be a challenge(?)
(assert 1)
(create-writer-body-response
(list (cons 'WWW-Authenticate (car extras)))
(lambda (port options)
(title-html port "Authorization Required")
(write-string "<P>Browser not authentication-capable or\n" port)
(write-string "authentication failed.\n" port)
(send-message port)
(close-html port))))
(title-html port "Authentication Required")
(format port "Client not authentication-capable or authentication failed.~%")
(close-html port (cdr extras)))))
((eq? code (status-code forbidden))
(create-response
(create-writer-body-response
'()
(lambda (port options)
(title-html port "Request not allowed.")
(format port
"Your client does not have permission to perform a ~A~%"
(request-method req))
(format port "operation on url ~a.~%" (request-uri req))
(send-message port)
(close-html port))))
(format port "The request the client sent is not allowed.~% Retrying won't help.~%")
(close-html port extras))))
((eq? code (status-code not-found))
(create-response
(create-writer-body-response
'()
(lambda (port options)
(title-html port "URL not found")
(write-string
"<P>The requested URL was not found on this server.\n"
port)
(send-message port)
(close-html port))))
(title-html port "Resource not found")
(format port "The requested resource ~A was not found on this server.~%"
(http-url->url-string (request-url req)))
(close-html port extras))))
((eq? code (status-code internal-error))
(create-response
(create-writer-body-response
'()
(lambda (port options)
(generic-title port)
(format port "The server encountered an internal error or
misconfiguration and was unable to complete your request.
<P>
Please inform the server administrator, ~A, of the circumstances leading to
the error, and time it occurred.~%"
(format port "This server encountered an internal error or misconfiguration and was unable to complete your request.~%<br/>~%Please inform the server administrator ~A of the circumstances leading to the error, and the time it occured.~%"
(or (httpd-options-server-admin options)
"[no mail address available]"))
(send-message port)
(close-html port))))
(close-html port extras))))
((eq? code (status-code not-implemented))
(create-response
(create-writer-body-response
'()
(lambda (port options)
(generic-title port)
(format port "This server does not currently implement
the requested method (~A).~%"
(format port "This server does not recognize or does not implement the requested method ~A.~%"
(request-method req))
(send-message port)
(close-html port))))
(close-html port extras))))
((eq? code (status-code bad-gateway))
(create-response
(create-writer-body-response
'()
(lambda (port options)
(generic-title port)
(format port "An error occurred while waiting for the
response of a gateway.~%")
(send-message port)
(close-html port)))))))
(format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
(close-html port extras))))
((eq? code (status-code version-not-supp))
(create-writer-body-response
'()
(lambda (port options)
(generic-title port)
(format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is 1.~%"
(car (request-version req)))
; (format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is ~D.~%"
; (car (request-version req))
; (car http-version))
(close-html port extras)))))))
(define (title-html out message)
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
(format out "<BODY>~%<H1>~A</H1>~%" message))
;;produce valid XHTML 1.0 Strict
(emit-prolog out)
(emit-tag out 'html xmlnsdecl-attr)
(format out "~%<head>~%<title>~%~A~%</title>~%</head>~%" message)
(format out "<body>~%<h1>~A</h1>~%<p>~%" message))
;; Creates a redirect response. The server will serve the new file
;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and
@ -270,7 +349,7 @@ response of a gateway.~%")
;; the browser won't notice the redirect. Thus, it will keep the
;; original URL. For "real" redirections, use
;; (make-error-response (status-code moved-perm) req
;; "new-location" "new-location").
;; "new-location").
(define (make-redirect-response new-location)
(make-response
(status-code redirect)

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

@ -20,7 +20,7 @@
((list? finder)
(lambda (url)
(values finder
(unescape-uri (http-url-search url))
(unescape (http-url-query url))
'())))
(else
(let ((man-path
@ -32,7 +32,7 @@
"")))))
(lambda (url)
(values man-path
(unescape-uri (http-url-search url))
(unescape (http-url-query url))
'()))))))
(reference-template
(cond
@ -62,17 +62,22 @@
'()
(make-writer-body
(lambda (out options)
(emit-prolog out)
(receive (man-path entry and-then)
(parse-man-url (request-url req))
(emit-man-page man-binary nroff-binary rman-binary
gzcat-binary
entry man man-path and-then reference-template out))
(with-tag out address ()
(with-tag out address () ;;außerhalb des html elements?
(display address out)))))))
(else
((or (string=? request-method "HEAD")
(string=? request-method "POST"))
(make-error-response (status-code method-not-allowed) req
request-method)))))))
"GET"))
(else
(make-error-response (status-code not-implemented) req)))))))
(define (cat-man-page key section out)
(let ((title (if section

110
scheme/httpd/seval.scm
View File

@ -38,69 +38,73 @@
(cond
((string=? request-method "POST") ; Could do others also.
(seval path req))
((or (string=? request-method "HEAD")
(string=? request-method "GET"))
(make-error-response (status-code method-not-allowed) req
"POST"))
(else
(make-error-response (status-code method-not-allowed) req request-method)))))
(make-error-response (status-code not-implemented) req)))))
(define (seval path req)
(let* ((message-body (read-message-body req))
(sexp (parse-request-sexp message-body)))
(make-response
(status-code ok)
#f
(time)
"text/html"
'()
(make-reader-writer-body
(lambda (iport oport options)
(let ((sexp (read-request-sexp req iport)))
(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(with-tag oport HEAD ()
(newline oport)
(emit-title oport "Scheme program output"))
(newline oport)
(with-tag oport BODY ()
(newline oport)
(do/timeout
10
(receive vals
;; Do the computation.
(begin (emit-header oport 2 "Output from execution")
(newline oport)
(with-tag oport PRE ()
(newline oport)
(force-output oport); In case we're gunned down.
(with-current-output-port oport
(eval-safely sexp))))
;; Pretty-print the returned value(s).
(emit-header oport 2 "Return value(s)")
(with-tag oport PRE ()
(for-each (lambda (val) (p val oport))
vals))))))))))
(make-writer-body
(lambda (oport options)
(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(emit-prolog oport)
(with-tag oport html (xmlnsdecl-attr)
(newline oport)
(with-tag oport head ()
(newline oport)
(emit-title oport "Scheme program output")
(newline oport))
(newline oport)
(with-tag oport body ()
(newline oport)
(do/timeout
10
(receive vals
;; Do the computation.
(begin (emit-header oport 1 "Output from execution")
(newline oport)
(with-tag oport pre ()
(newline oport)
(force-output oport); In case we're gunned down.
(with-current-output-port oport
(eval-safely sexp))))
;; Pretty-print the returned value(s).;; hier noch mal newline rausschreiben?
(emit-header oport 1 "Return value(s)")
(with-tag oport pre ()
(for-each (lambda (val) (p val oport))
vals)))))))))))
;;; Read an HTTP request entity body from stdin. The Content-length:
;;; element of request REQ's header tells how many bytes to this entity
;;; is. The entity should be a URI-encoded form body. Pull out the
;;; program=<stuff>
;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
;;; and return it.
;;; Parse the request's message body.
(define (read-request-sexp req iport)
(cond
((get-header (request-headers req) 'content-length) =>
(lambda (cl-str) ; Take the first Content-length: header,
(let* ((cl-start (string-skip cl-str char-set:whitespace)) ; skip whitespace,
(cl (if cl-start ; & convert to
(string->number (substring cl-str ; a number.
cl-start
(string-length cl-str)))
0)) ; All whitespace?? -- WTF.
(qs (read-string cl iport)) ; Read in CL chars,
(q (parse-html-form-query qs)) ; and parse them up.
(s (cond ((assoc "program" q) => cdr)
(else (error "No program in entity body.")))))
(http-syslog (syslog-level debug)
"Seval sexp: ~s" s)
(read (make-string-input-port s)))))
(else (error "No `Content-length:' field in POST request."))))
;;; We assume, that the entity is "form-url encoded" data (see
;;; parse-forms.scm for a description of this encoding). This
;;; assumption is rather strange - it may safely be made only if
;;; there's a "Content-type: application/x-www-form-urlencoded" header.
;;; Pull out the program=<stuff> string, extract <stuff>,
;;; parse that into an s-expression, and return it.
(define (parse-request-sexp body)
(let* ((parsed-html-form-query (parse-html-form-query body))
(program (cond ((assoc "program" parsed-html-form-query) => cdr)
(else (fatal-syntax-error "No program was found in request's message body.")))))
(http-syslog (syslog-level debug)
"Seval sexp: ~s" program)
(with-fatal-error-handler
(lambda (c decline)
(fatal-syntax-error "The program in the request's message body isn't a valid s-expression"))
(read (make-string-input-port program))))) ;; return first sexp, discard others

39
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
@ -26,7 +26,7 @@
'application/x-www-form-urlencoded' as content-type"))
(cond
((string=? request-method "GET")
(form-query-list (http-url-search
(form-query-list (http-url-query
(surflet-request-url surflet-request))))
((string=? request-method "POST")
(or (cached-bindings surflet-request)
@ -54,30 +54,23 @@
(define (cached-bindings surflet-request)
(obtain-lock *cache-lock*)
(let ((result
(let loop ((predecessor #f)
(cache *POST-bindings-cache*))
(if (null? cache)
#f ; no such request cached
(let* ((head (car cache))
(s-req (weak-pointer-ref (car head))))
(if s-req
(if (eq? s-req surflet-request)
(cdr head) ; request is cached
(loop (if predecessor
(cdr predecessor)
cache)
(cdr cache))) ; request isn't cached
(begin ;; request object is gone ==> remove
;; it from list
(if predecessor
(set-cdr! predecessor (cdr cache))
(set! *POST-bindings-cache* (cdr cache)))
(loop predecessor
(cdr cache)))))))))
(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))))))))
(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,8 +124,7 @@
((real-input-field-transformer real-input-field) input-field bindings))
((real-input-field-binding real-input-field bindings) =>
(lambda (binding)
((real-input-field-transformer real-input-field)
input-field (cdr binding))))
((real-input-field-transformer real-input-field) (cdr binding))))
(else
(error "no such input-field" input-field bindings)))))

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

@ -1,16 +1,35 @@
;;; This file is meant for developing. Use the example startup
;;; scripts to start the webserver,
;;; e.g. $SCSH_LIB_DIRS/sunet/web-server/start-surflet-server
;;; Reads package descriptions in the right order. In the end, the
;;; server can be started via SERVER. Assumes scsh has been started with
;;; SSAX loaded: scsh -lel SSAX/load.scm (otherwise surflets won't work)
;;; and it is called with cwd=sunet/scheme/httpd/surflets/
; reads package description in the right order
; in the end, the server can be started via (server)
(batch 'on)
(config `(load "../../packages.scm"))
(config `(load "packages.scm"))
(config `(load "../../../web-server/start-surflet-server"))
(define *ASSUMED-SUNET-HOME*
(in 'scsh '(run (match:substring
(regexp-search (rx (submatch (* any) "sunet")) (cwd))
1))))
(define *SUNET-PACKAGE*
(in 'scsh `(run (string-append
(or (getenv "SUNETHOME")
,*ASSUMED-SUNET-HOME*)
"/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*))
(user)
(open 'surflet-server)
(batch 'off)

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

@ -122,7 +122,6 @@
session-alive?
session-surflet-name
session-session-id
set-session-lifetime!
options-surflet-path
options-session-lifetime
options-cache-surflets?
@ -148,8 +147,7 @@
(define-interface surflet-handler/surflets-interface
(export get-loaded-surflets
unload-surflet
reset-surflet-cache!))
unload-surflet))
(define-interface surflet-handler/options-interface
(export make-surflet-options
@ -193,7 +191,6 @@
form-query
inform
final-page
make-text
make-password
make-number
make-boolean
@ -255,6 +252,25 @@
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)))
@ -383,9 +399,7 @@
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
@ -423,12 +437,13 @@
let-opt ;:OPTIONAL
locks ;MAKE-LOCK et al.
profiling ;PROFILE-SPACE
rt-modules ;get structures dynamically
rt-module-language ;get structures dynamically
scheme-with-scsh ;regexp et al.
search-trees
shift-reset ;SHIFT and RESET
(subset srfi-1 (alist-cons alist-delete!))
srfi-6 ;string-ports
(subset srfi-13 (string-join))
srfi-14 ;CHAR-SET:DIGIT
srfi-27 ;random numbers
surflet-requests ;requests for surflets
@ -453,14 +468,6 @@
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
@ -565,7 +572,7 @@
)
(files input-fields))
(define-structure surflets/input-fields surflets/my-input-fields)
(define-structure surlfets/input-fields surflets/my-input-fields)
(define-structure surflets/surflet-input-fields
surflets/surflet-input-fields-interface
@ -620,7 +627,6 @@
(define-structure surflets/addresses surflets/addresses-interface
(open scheme
srfi-23 ;error
(subset uri (escape-uri))
define-record-types
(subset surflets/utilities (generate-unique-name)))
(files addresses))
@ -638,7 +644,7 @@
(open scheme
surflets/input-field-value
surflets/addresses
(subset uri (unescape-uri)))
(subset uri (unescape)))
(files returned-via))
(define-structure surflets/outdaters surflets/outdaters-interface
@ -653,7 +659,7 @@
weak ;weak pointers
surflets/utilities ;form-query-list
surflet-requests
(subset url (http-url-search))
(subset url (http-url-query))
(subset srfi-14 (char-set:digit))
(subset srfi-13 (string-index string-trim))
(subset srfi-1 (filter))
@ -669,6 +675,53 @@
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)
@ -676,5 +729,5 @@
;;; EOF
;;; Local Variables:
;;; buffer-tag-table: "../../../TAGS"
;;; buffer-tag-table: "../../TAGS"
;;; End::

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

@ -0,0 +1,58 @@
;; rt-module.scm
;; Copyright Martin Gasbichler, 2002
;; Receipt:
;;(load-config-file "test.scm") --> nothing
;; load config file containing structure definition
;;
;; (reify-structure 'surflet) --> #{Rt-stucture surflet}
;; gets structure info about a structure
;;
;; (define surflet ##)
;; (load-structure surflet)
;; loads rt-structure
;;
;; (rt-structure-binding surflet 'main) --> value
;; get a binding of a structure
(define (interface-value-names interface-name)
(let ((interface (environment-ref (config-package) interface-name))
(value-names '()))
(for-each-declaration
(lambda (name base-neme type)
(if (not (equal? type syntax-type))
(set! value-names (cons name value-names))))
interface)
value-names))
(define-record-type rt-structure :rt-structure
(make-rt-structure meta-structure)
rt-structure?
(meta-structure rt-structure-meta-structure))
(define (rt-structure-loaded? rt-structure)
(package-loaded?
(structure-package (rt-structure-meta-structure rt-structure))))
(define-record-discloser :rt-structure
(lambda (s)
(list 'rt-stucture (structure-name (rt-structure-meta-structure s)))))
(define (reify-structure name)
(let ((struct (get-structure name)))
(make-rt-structure struct)))
(define (load-structure rts)
(ensure-loaded (rt-structure-meta-structure rts)))
(define (rt-structure-binding structure name)
(if (not (rt-structure-loaded? structure))
(error "Structure not loaded" structure))
(contents
(binding-place
(generic-lookup (rt-structure-meta-structure structure)
name))))
(define (load-config-file file)
(load file (config-package)))

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

@ -1,60 +0,0 @@
(define processing-instruction-rule
`(*PI* *preorder*
. ,(lambda (tag . elems)
`(,(string-append "<?" (symbol->string (car elems)) " ")
,@(cdr elems)
"?>"))))
(define doctype-rule
`(*DOCTYPE* *preorder*
. ,(lambda (content . more)
`("<!DOCTYPE " ,@more ">"))))
(define xml-default-rule
`(*default* .
,(lambda (tag . elems)
(apply (entag tag) elems))))
(define (entag tag)
(lambda elems
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
(list #\< tag (cdar elems)
(if (pair? (cdr elems)) (list #\> (cdr elems) "</" tag #\>)
"/>"))
(list #\< tag
(if (pair? elems) (list #\> elems "</" tag #\>) "/>")))))
(define comment-rule
`(*COMMENT* *preorder*
. ,(lambda (tag . elems)
`("<!-- " ,@elems "-->"))))
(define xml-rules
(list attribute-rule
xml-default-rule
processing-instruction-rule
doctype-rule
text-rule
comment-rule
url-rule
plain-html-rule
nbsp-rule))
(define (make-xml-reponse xml-string)
(make-surflet-response
(status-code ok)
"text/xml"
'(("Cache-Control" . "no-cache"))
xml-string))
(define (send-xml/suspend xml-tree-maker)
(send/suspend
(lambda (k-url)
(make-xml-reponse
(sxml->string (xml-tree-maker k-url)
xml-rules)))))
(define (send-xml/finish xml-tree)
(send
(make-xml-reponse
(sxml->string xml-tree xml-rules))))

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

@ -44,7 +44,7 @@
(lambda (path req)
(if (pair? path) ; need at least one element
(let ((request-method (request-method req))
(path-string (uri-path->uri path)))
(path-string (string-join path "/")))
(if (or (string=? request-method "GET")
(string=? request-method "POST"))
(make-input-response
@ -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)))
(register-session-timeout! session-id (+ (time) lifetime))
(timeout-queue-register-session! session-id (+ (time) lifetime))
(reset
(with-fatal-error-handler
@ -117,32 +117,34 @@
;;; SESSION-SURVEILLANCE
(define *session-timeouts*)
(define *timeout-queue*)
(define (register-session-timeout! session-id timeout)
(table-set! *session-timeouts* session-id timeout))
(define (timeout-queue-register-session! session-id timeout)
(search-tree-set! *timeout-queue* (cons session-id timeout) 'ignore))
(define (remove-session-timeout! session-id)
(table-set! *session-timeouts* session-id #f))
(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 (adjust-session-timeout! session-id new-timeout)
(table-set! *session-timeouts* session-id new-timeout))
(define (surveillance-thread)
(set! *session-timeouts* (make-integer-table))
(set! *timeout-queue* (make-search-tree (lambda (p q) (eq? (car p) (car q)))
(lambda (p q)
(< (cdr p) (cdr q)))))
(let lp ()
(with-lock *session-table-lock*
(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)
(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)
(lp)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -264,7 +266,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 (wrong data type in surflet-response)."))))
"The SUrflet returned an invalid response object (no surflet-response)."))))
((and (response? response) ;; RESPONSE? refers to a HTTP-RESPONSE.
(redirect-body? (response-body response)))
response)
@ -300,7 +302,7 @@
(let ((session (table-ref *session-table* session-id)))
(if session
(begin
(remove-session-timeout! session-id)
(timeout-queue-remove-session! session-id)
(table-set! *session-table* session-id #f))
;; else: somebody was faster than we
))))
@ -318,7 +320,7 @@
(with-lock *session-table-lock*
(let ((session (table-ref *session-table* session-id)))
(if session
(adjust-session-timeout!
(timeout-queue-adjust-session-timeout!
session-id
(+ (time) time-to-live))
(error "There is no session with this ID" session-id)))))
@ -358,7 +360,7 @@
;; notify session killing
(table-walk
(lambda (session-id session)
(remove-session-timeout! session-id))
(timeout-queue-remove-session! 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? error-msg-types)
(define (make-simple-default-setter default-pred?)
(lambda (input-field value)
(if (default-pred? value)
(set-field-attributes-default!
(input-field-attributes input-field)
`(value ,value))
(error (format #f "Default value must be ~a." error-msg-types)
(error "Default value must be a number or a string or a symbol."
value))
(touch-input-field! input-field)))
@ -54,14 +54,12 @@
(define simple-default? string-or-symbol?)
(define set-simple-field-default!
(make-simple-default-setter simple-default? "a string or a symbol"))
(define (second-arg first second) second)
(make-simple-default-setter simple-default?))
;;;;;;;;;;;;;;;;;;;;
;;; Text input field
(define make-text-field
(simple-field-maker "text" "text" simple-default? second-arg))
(simple-field-maker "text" "text" simple-default? identity))
(define set-text-field-value! set-simple-field-default!)
;;;;;;;;;;;;;;;;;;;;;;
@ -69,15 +67,14 @@
(define (number-field-default? value)
(or (number? value)
(simple-default? value)))
(define (number-field-transformer input-field string)
(define (number-field-transformer string)
(or (string->number string)
(error "wrong type")))
(define make-number-field
(simple-field-maker "text" "number"
number-field-default? number-field-transformer))
(define set-number-field-value!
(make-simple-default-setter number-field-default?
"a number a string or a symbol"))
(make-simple-default-setter number-field-default?))
;;;;;;;;;;;;;;;;;;;;;;
;;; hidden input-field
@ -85,14 +82,14 @@
;; as it is hidden.
(define make-hidden-field
(simple-field-maker "hidden" "hidden"
simple-default? second-arg))
simple-default? identity))
(define set-hidden-field-value! set-simple-field-default!)
;;;;;;;;;;;;;;;;;;;;;;;;
;;; Password input field
(define make-password-field
(simple-field-maker "password" "password"
simple-default? second-arg))
simple-default? identity))
(define set-password-field-value! set-simple-field-default!)
;;; That's it for simple input fields.
@ -113,7 +110,7 @@
,@(sxml-attribute-attributes attributes))))
(make-input-field
name "textarea"
second-arg
identity
(make-field-attributes (and default-text)
all-attributes)
make-textarea-html-tree))))
@ -285,7 +282,7 @@
;; internal
(define (make-single-select name select-options attributes)
(make-input-field name "select"
(lambda (input-field tag)
(lambda (tag)
(cond ((find-select-option-value tag select-options)
=> identity)
(else (error "no such option." tag))))
@ -333,7 +330,7 @@
((checked? #f boolean?)
(attributes '() sxml-attribute?))
(make-input-field name "radio"
second-arg
identity
(make-field-attributes
(and checked? '(checked))
`((value ,value-string)
@ -370,7 +367,7 @@
(define (make-radio-transformer value-table)
(lambda (input-field tag)
(lambda (tag)
(cond
((string->number tag) =>
(lambda (number)
@ -401,7 +398,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;
;;; checkbox input-field
(define (make-checkbox . maybe-further-attributes)
(really-make-checkbox 'defined-in-checkbox-transformer
(really-make-checkbox #t
checkbox-transformer
maybe-further-attributes))
@ -423,7 +420,7 @@
checkbox-html-tree-maker))))
(define (make-checkbox-transformer value)
(lambda (input-field tag)
(lambda (tag)
(if (string=? tag "on")
value
#f)))
@ -446,7 +443,7 @@
;; button input-fields
(define (make-button type name button-caption attributes)
(make-input-field name type
second-arg
identity
(make-field-attributes
(and button-caption `(value ,button-caption))
(sxml-attribute-attributes attributes))

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

@ -7,11 +7,6 @@
(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,7 +53,6 @@
`(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,6 +2,10 @@
;;; 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)
@ -27,7 +31,7 @@
(call-with-string-output-port
(lambda (port)
(display-low-level-sxml
(sxml->low-level-sxml sxml-tree rules)
(pre-post-order 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"))

67
scheme/lib/htmlout.scm
View File

@ -11,6 +11,34 @@
;;; HTML text representation -- surrounding it with single or double quotes,
;;; as appropriate, etc.
;;XHTML 1.0 Strict
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a well-formed XML document begins with a prolog;
;; this is the prolog for an XHTML 1.0 strict document:
(define XMLdecl
"<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
(define doctypedecl
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
(define (emit-prolog out)
(display XMLdecl out)
(newline out)
(display doctypedecl out)
(newline out))
;; the root element html must contain an xmlns declaration for the
;; XHTML namespace, which ist defined to be
;; http://www.w3.org/1999/xhtml
(define xmlnsval "http://www.w3.org/1999/xhtml")
;; for use with emit-tag and with-tag:
(define xmlnsdecl-attr (cons 'xmlns xmlnsval))
;;; Printing HTML tags.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; All the emit-foo procedures have the same basic calling conventions:
@ -42,6 +70,26 @@
attrs)
(display #\> out)))
;;; Empty elements, e.g. <hr />
(define (emit-empty-tag out tag . attrs)
(let ((out (fmt->port out)))
(display "<" out)
(display tag out)
(for-each (lambda (attr)
(display #\space out)
(cond ((pair? attr) ; name="val"
(display (car attr) out)
(display "=\"" out) ; Should check for
(display (cdr attr) out) ; internal double-quote
(display #\" out)) ; etc.
(else
(display attr out)))) ; name
attrs)
(display " /" out)
(display #\> out)))
;;; </tag>
@ -49,7 +97,7 @@
(format out "</~a>" tag))
;;; <P>
;;; <p>
(define (emit-p . args) ; (emit-p [out attr1 ...])
(receive (out attrs) (if (pair? args)
@ -61,13 +109,13 @@
(apply emit-tag out 'p attrs)))
;;; <TITLE> Make Money Fast!!! </TITLE>
;;; <title> Make Money Fast!!! </title>
(define (emit-title out title) ; Takes no attributes.
(format out "<title>~a~%</title>~%" title))
(format out "<title>~a</title>" title))
(define (emit-header out level text . attribs)
(apply with-tag* out (string-append "H" (number->string level))
(apply with-tag* out (string-append "h" (number->string level))
(lambda () (display text (fmt->port out)))
attribs))
@ -90,11 +138,11 @@
;;; instead of (NAME VALUE).
;;;
;;; For example,
;;; (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page.
;;; (with-tag port A ((href hp-url) (name "hp"))
;;; (let ((hp-url "http://clark.lcs.mit.edu/~shivers")) ; My home page.
;;; (with-tag port a ((href hp-url) (name "hp"))
;;; (display "home page" port)))
;;; outputs
;;; <A href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</A>
;;; <a href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</a>
(define-syntax with-tag
(syntax-rules ()
@ -107,9 +155,11 @@
;;; Why can't this be a LET-SYNTAX inside of WITH-TAG?
(define-syntax %hack-attr-elt
(syntax-rules () ; Build attribute-list element:
(syntax-rules (xmlnsdecl-attr) ; Build attribute-list element:
((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt)
(cons 'name val))
((%hack-attr-elt xmlnsdecl-attr)
xmlnsdecl-attr)
((%hack-attr-elt name) 'name))) ; name => 'name
@ -191,3 +241,4 @@
(if (null? maybe-port)
(write-string (escape-html s))
(write-string (escape-html s) (fmt->port (car maybe-port)))))

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

@ -12,12 +12,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The form's field data are turned into a single string, of the form
;;; name=val&name=val
;;; where the <name> and <val> parts are URI encoded to hide their
;;; &, =, and + chars, among other things. After URI encoding, the
;;; space chars are converted to + chars, just for fun. It is important
;;; to encode the spaces this way, because the perfectly general %xx escape
;;; mechanism might be insufficiently confusing. This variant encoding is
;;; called "form-url encoding."
;;; where the <name> and <val> parts are URI encoded to hide their &,
;;; =, and + chars and other reserves or excluded characters. After
;;; URI encoding, the space chars are converted to + chars, just for
;;; fun. It is important to encode the spaces this way, because the
;;; perfectly general %xx escape mechanism might be insufficiently
;;; confusing. This variant encoding is called "form-url encoding."
;;;
;;; If the form's method is POST,
;;; Browser sends the form's field data in the entity block, e.g.,
@ -32,6 +32,7 @@
;;;
;;; In either case, the data is "form-url encoded" (as described above).
(define (parse-html-form-query q)
(let ((qlen (string-length q)))
(let recur ((i 0))
@ -46,11 +47,11 @@
(else '()))))) ; BOGUS STRING -- Issue a warning.
;;; Map plus characters to spaces, then do URI decoding.
;;; Map plus characters to spaces, then unescape.
(define (unescape-uri+ s . maybe-start/end)
(let-optionals maybe-start/end ((start 0)
(end (string-length s)))
(unescape-uri (string-map (lambda (c) (if (char=? c #\+) #\space c))
(unescape (string-map (lambda (c) (if (char=? c #\+) #\space c))
(if (and (zero? start)
(= end (string-length s)))
s ; Gratuitous optimisation.

2
scheme/lib/smtp.scm
View File

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

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

@ -2,10 +2,10 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; interpolate hostname or IP address from socket local address. return a string
(define (host-name-or-ip addr)
(with-fatal-error-handler
(lambda (condition more)
@ -68,7 +68,6 @@
(lambda ()
(release-lock lock))))
;; Get Header from (RFC822 like) header alist
(define (get-header headers tag)
(cond ((assq tag headers) => cdr)

243
scheme/lib/uri.scm
View File

@ -3,93 +3,51 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; Copyright (c) 2004 by Viola Brunner.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; URI syntax -- [scheme] : path [? search ] [# fragmentid]
;;; References:
;;; - http://www.w3.org/Addressing/rfc1630.txt
;;; Original RFC
;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/URI_Overview.html
;;; General Web page of URI pointers.
;;; RFC 2396 Uniform Resource Identifiers (URI): Generic Syntax
(define uri-reserved (string->char-set ";/#?: ="))
(define uri-reserved-sans-= (char-set-delete uri-reserved #\=))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; decode a URI
;;; walk over string s and unescape all occurrences of RegExp 'escaped' (see url.scm).
(define (parse-uri s)
(let* ((slen (string-length s))
;; Search forwards for colon (or intervening reserved char).
(rs1 (string-index s uri-reserved)) ; 1st reserved char
(colon (and rs1 (char=? (string-ref s rs1) #\:) rs1))
(path-start (if colon (+ colon 1) 0))
;copy from url.scm:
(define hex (rx hex-digit))
(define escaped (rx (: "%" ,hex ,hex)))
;; Search backwards for # (or intervening reserved char).
(rs-last (string-index-right s uri-reserved))
(sharp (and rs-last (char=? (string-ref s rs-last) #\#) rs-last))
;; Search backwards for ? (or intervening reserved char).
;; (NB: #\= may be after #\? and before #\#)
(rs-penult (string-index-right s
uri-reserved-sans-=
path-start
(or sharp slen)))
(ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult))
(path-end (or ques sharp slen)))
(values (and colon (substring s 0 colon))
(split-uri s path-start path-end)
(and ques (substring s (+ ques 1) (or sharp slen)))
(and sharp (substring s (+ sharp 1) slen)))))
;;; Remark:
;;; we assume no non-ASCII characters occur in the URI; therefore the
;;; ascii table is used for conversion of the octet the hexnumber
;;; represents to a char.
;;; Caution:
;;; Don't use this proc until *after* you've parsed the URL -- unescaping
;;; might introduce reserved chars (like slashes and colons) that could
;;; blow your parse.
;;; a URI must be separated into its components (for a HTTP-URL e.g. parsed by
;;; PARSE-URL) before the escaped characters within those components
;;; can be safely decoded. Don't use UNESCAPE on an unparsed URI.
(define (unescape-uri s . maybe-start/end)
(let-optionals maybe-start/end ((start 0)
(end (string-length s)))
(let* ((esc-seq? (lambda (i) (and (< (+ i 2) end)
(char=? (string-ref s i) #\%)
(hex-digit? (string-ref s (+ i 1)))
(hex-digit? (string-ref s (+ i 2))))))
(hits (let lp ((i start) (hits 0)) ; count # of esc seqs.
(if (< i end)
(if (esc-seq? i)
(lp (+ i 3) (+ hits 1))
(lp (+ i 1) hits))
hits))))
(if (and (zero? hits) (zero? start) (= end (string-length s)))
s
(let* ((nlen (- (- end start) (* hits 2))) ; the new length
; of the
; unescaped
; string stores
; the result
(ns (make-string nlen)))
(define (unescape s)
(regexp-fold
escaped
(lambda (start-search match res)
(let* ((start-match (match:start match))
(hexchar-low (string-ref s (+ start-match 2)))
(hexchar-high (string-ref s (+ start-match 1)))
(hex-low (hexchar->int hexchar-low))
(hex-high (hexchar->int hexchar-high))
(ascii (+ (* 16 hex-high) hex-low)))
(string-append
res
(substring s start-search start-match)
(string (ascii->char ascii)))))
""
s
(lambda (start-search res)
(string-append res (substring s start-search (string-length s))))))
(let lp ((i start) (j 0)) ; sweep over the string
(if (< j nlen)
(lp (cond
((esc-seq? i) ; unescape
; escape-sequence
(string-set! ns j
(let ((d1 (string-ref s (+ i 1)))
(d2 (string-ref s (+ i 2))))
(ascii->char (+ (* 16 (hexchar->int d1))
(hexchar->int d2)))))
(+ i 3))
(else (string-set! ns j (string-ref s i))
(+ i 1)))
(+ j 1))))
ns)))))
(define hex-digit?
(let ((hex-digits (string->char-set "0123456789abcdefABCDEF")))
(lambda (c) (char-set-contains? hex-digits c))))
; make use of the fact that numbers and characters are in order in the ascii table
(define (hexchar->int c)
@ -101,100 +59,47 @@
(char->ascii #\a))
10))))
(define int->hexchar
(let ((table '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
#\A #\B #\C #\D #\E #\F)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; encode a URI:
;;; replace characters which are reserved or excluded by their escaped representation.
;;; Caution:
;;; Each component of a URI may have its own set of characters that are reserved,
;;; -> differentiate between components by writing specialized procedures
;;; (see url.scm for examples)
;;; Caution:
;;; don't encode an already encoded string; #\% chars would be escaped again.
;;; escape occurrences of RegExp regexp in string s
(define (escape s regexp)
(regexp-fold
regexp
(lambda (start-search match res)
(let* ((start-match (match:start match))
(forbidden-char (string-ref s start-match)))
(string-append
res
(substring s start-search start-match)
(ascii->escaped (char->ascii forbidden-char)))))
""
s
(lambda (start-search res)
(string-append res (substring s start-search (string-length s))))))
;;;generate string representing hex-ascii-code for the decimal-ascii-code DEC-INT
(define (ascii->escaped dec-int)
(let* ((hex-int-high (bitwise-and (arithmetic-shift dec-int -4) #xF))
(hex-int-low (bitwise-and dec-int #xF)))
(string-append
"%" (int->hexstring hex-int-high) (int->hexstring hex-int-low))))
(define int->hexstring
(let ((table '#("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
"A" "B" "C" "D" "E" "F")))
(lambda (i) (vector-ref table i))))
;;; Caution:
;;; All reserved chars (e.g., slash, sharp, colon) get escaped: "=;/#?: "
;;; So don't apply this proc to chunks of text with syntactically meaningful
;;; reserved chars (e.g., paths with URI slashes or colons) -- they'll be
;;; escaped, and lose their special meaning. E.g. it would be a mistake
;;; to apply ESCAPE-URI to "//lcs.mit.edu:8001/foo/bar.html" because the
;;; slashes and colons would be escaped.
(define uri-escaped-chars
(char-set-complement
;; RFC 2396 (URI Generic Syntax) specifies unreserved = alphanum | mark
(char-set-union char-set:letter+digit
(string->char-set "-_.!~*'()"))))
;;; Takes a set of chars to escape. This is because we sometimes need to
;;; escape larger sets of chars for different parts of a URI.
(define (escape-uri s . maybe-escaped-chars)
(let-optionals maybe-escaped-chars ((escaped-chars uri-escaped-chars))
(let ((nlen (string-fold
(lambda (c i)
(+ i
(if (char-set-contains? escaped-chars c)
3
1)))
0
s))) ; new length of escaped string
(if (= nlen (string-length s))
s
(let ((ns (make-string nlen)))
(string-fold
(lambda (c i) ; replace each occurance of an
; character to escape with %ff where ff
; is the ascii-code in hexadecimal
; notation
(+ i (cond
((char-set-contains? escaped-chars c)
(string-set! ns i #\%)
(let* ((d (char->ascii c))
(dhi (bitwise-and (arithmetic-shift d -4) #xF))
(dlo (bitwise-and d #xF)))
(string-set! ns (+ i 1)
(int->hexchar dhi))
(string-set! ns (+ i 2)
(int->hexchar dlo)))
3)
(else (string-set! ns i c)
1))))
0
s)
ns)))))
;;; Cribbed from scsh's fname.scm
(define (split-uri uri start end) ; Split at /'s (infix grammar).
(let split ((i start)) ; "" -> ("")
(cond
((>= i end) '(""))
((string-index uri #\/ i) =>
(lambda (slash)
(cons (substring uri i slash)
(split (+ slash 1)))))
(else (list (substring uri i end))))))
;;; The elements of PLIST must be escaped in case they contain slashes.
;;; This procedure doesn't escape them for you; you must do that yourself:
;;; (uri-path->uri (map escape-uri pathlist))
(define (uri-path->uri plist)
(string-join plist "/")) ; Insert slashes between elts of PLIST.
(define (simplify-uri-path p)
(if (null? p)
#f ; P must be non-null
(let lp ((path-list (cdr p))
(stack (list (car p))))
(if (null? path-list) ; we're done
(reverse stack)
(cond
((string=? (car path-list) "..") ; back up
; neither the empty path nor root
(if (not (or (null? stack) (string=? (car stack) "")))
(lp (cdr path-list) (cdr stack))
#f))
((string=? (car path-list) ".") ; leave this
(lp (cdr path-list) stack))
((string=? (car path-list) "") ; back to root
(lp (cdr path-list) '("")))
(else ; usual segment
(lp (cdr path-list) (cons (car path-list) stack))))))))

518
scheme/lib/url.scm
View File

@ -1,173 +1,399 @@
;;; URL parsing and unparsing -*- Scheme -*-
;;; HTTP 1.1 Request-URI parsing and unparsing -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; I'm only implementing HTTP URL's right now.
;;; References:
;;; - http://www.w3.org/Addressing/rfc1738.txt
;;; Original RFC
;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/Overview.html
;;; General Web page of URI pointers.
;;; RFC 2616 Hypertext Transfer Protocol -- HTTP/1.1
;;; RFC 2396 Uniform Resource Identifiers (URI): Generic Syntax
;;;
;;; RFC 2616 adopts definitions of regexps from RFC 2396
;;; (see copy of Appendix A of RFC 2396 below)
;;; Unresolved issues:
;;; - The server parser shouldn't substitute default values --
;;; that should happen in a separate step.
;;; Note: there are 2 Problems in RFC 2616 concerning URIS:
;;; The steps in hacking a URL are:
;;; - Take the UID, parse it, and resolve it with the context UID, if any.
;;; - Consult the UID's <scheme>. Pick the appropriate URL parser and parse.
;;; Problem 1:
;;; RFC 2616 is ambiguous in defining Request_URIS:
;;;
;;; section 5.1.2 states:
;;; HTTP 1.1 Request-URIS are of the form
;;; Request-URI = "*" | absoluteURI | abs_path | authority
;;;
;;; whilst section 3.2.2 defines the 'http_URL'
;;; http_URL = "http://" host [ ":" port ] [ abs_path [ "?" query ]]
;;;
;;; Solution to Problem 1:
;;; Since allowing for general absoluteURIs doesn't make too much sense
;;; we implement Request_URIs of the form
;;; Request-URI = ( http_URL | abs_path) ["#" fragment]
;;; where http_URL is a only a subset of absoluteURI
;;; Server strings: //<user>:<password>@<host>:<port>/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A SERVER record describes path-prefixes of the form
;;; //<user>:<password>@<host>:<port>/
;;; These are frequently used as the initial prefix of URL's describing
;;; Internet resources.
(define-record-type server :server ; Each slot is a decoded string or #f.
(make-server user password host port)
server?
(user server-user)
(password server-password)
(host server-host)
(port server-port))
(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
;;; it wins. CADDR drops the server portion of the path. In fact,
;;; fatal-syntax-error is called, if the path doesn't start with '//'.
;
(define (parse-server path default)
(if (and (pair? path) ; The thing better begin
(string=? (car path) "") ; with // (i.e., have two
(pair? (cdr path)) ; initial "" elements).
(string=? (cadr path) ""))
(let* ((uhs (caddr path)) ; Server string.
(uhs-len (string-length uhs))
(at (string-index uhs #\@)) ; Usr:passwd at-sign, if any.
(colon1 (and at (string-index uhs #\:))) ; Usr:passwd colon,
(colon1 (and colon1 (< colon1 at) colon1)) ; if any.
(colon2 (string-index uhs #\: (or at 0)))) ; Host:port colon, if any.
(make-server (if at
(unescape-uri uhs 0 (or colon1 at))
(server-user default))
(if colon1
(unescape-uri uhs (+ colon1 1) at)
(server-password default))
(unescape-uri uhs (if at (+ at 1) 0)
(or colon2 uhs-len))
(if colon2
(unescape-uri uhs (+ colon2 1) uhs-len)
(server-port default))))
(fatal-syntax-error "URL must begin with //..." path)))
;;; Unparser
(define server-escaped-chars
(char-set-union uri-escaped-chars ; @ and : are also special
(string->char-set "@:"))) ; in UH strings.
(define (server->string uh)
(let* ((us (server-user uh))
(pw (server-password uh))
(ho (server-host uh))
(po (server-port uh))
;; Encode before assembly in case pieces contain colons or at-signs.
(e (lambda (s) (escape-uri s server-escaped-chars)))
(user/passwd (if us
`(,(e us) . ,(if pw `(":" ,(e pw) "@") '("@")))
'()))
(host/port (if ho
`(,(e ho) . ,(if po `(":" ,(e po)) '()))
'())))
(apply string-append (append user/passwd host/port))))
;;; Problem 2:
;;; according to RFC 2616, section 5.1.2, the Request-URI may only
;;; have a [? query] part if it's an absoluteURI; on the other hand
;;; only requests being made to proxies are supposed to use
;;; absoluteURIs; abs_path is the normal case. So this must be a mistake.
;;; See also http://skrb.org/ietf/http_errata.html#uriquery
;;;
;;; Solution to Problem 2:
;;, we implement Request_URIs of the form
;;; Request-URI = ( http_URL | abs_path ["?" query] ) ["#" fragment]
;;; HTTP URL parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note: we don't have to support Request-URIS of the form "*" or
;;; authority, because these are not used with the any of the methods
;;; HEAD, GET and POST, which are the only methods we implement so
;;; far.
;;; The PATH slot of this record is the URL's path split at slashes,
;;; e.g., "foo/bar//baz/" => ("foo" "bar" "" "baz" "")
;;; These elements are in raw, unescaped format. To convert back to
;;; a string, use (uri-path->uri (map escape-uri pathlist)).
;;; Here we depart from the RFCs:
;;; RFC 2616 and 1945 disallow a #fragment-suffix of the Request-URI.
;;; For compatibility with buggy clients we _do_ allow for it.
;;; (Apache does so, too).
;;; RexExps for Request-URIs as scsh SREs
;;; stick to RFC terminology throughout
;;; (see copy of Appendix A of RFC 2396 below)
;;;
;;; we implement Request_URIs of the form
;;; Request-URI = ( http_URL | abs_path ["?" query] ) ["#" fragment]
(define digit (rx numeric))
(define alpha (rx alphabetic))
(define alphanum (rx alphanumeric))
(define hex (rx hex-digit))
(define escaped (rx (: "%" ,hex ,hex)))
(define mark (rx ( "-_.!~*'()")))
(define unreserved (rx (~ (~ (| ,alphanum ,mark)))))
(define reserved (rx ( ";/?:@&=+$,")))
(define uric (rx (| ,reserved ,unreserved ,escaped)))
(define fragment (rx (* ,uric)))
(define query (rx (* ,uric)))
(define pchar-charset (rx ( ":@&=+$,")))
(define pchar (rx (| ,unreserved ,escaped ,pchar-charset)))
(define param (rx (* ,pchar)))
(define segment (rx (:
(* ,pchar)
(* (: ";" ,param)))))
(define path-segments (rx (:
,segment
(* (: "/" ,segment)))))
(define abs_path (rx (:
"/"
,path-segments)))
(define port (rx (* ,digit)))
(define IPv4address (rx (+ ,digit) "." (+ ,digit) "." (+ ,digit) "." (+ ,digit)))
(define toplabel (rx (:
(|
,alpha
(:
,alpha
(* (| ,alphanum "-"))
,alphanum)))))
(define domainlabel (rx (:
(|
,alphanum
(: ,alphanum
(* (| ,alphanum "-"))
,alphanum)))))
(define hostname (rx (:
(* (: ,domainlabel "."))
,toplabel
(? "."))))
(define host (rx (| ,hostname ,IPv4address)))
(define http_URL (rx (:
"http://"
(submatch ,host)
(?
(: ":" (submatch ,port)))
(?
(: (submatch ,abs_path)
(?
(: "?" (submatch ,query))))))))
(define http_URL_with_frag (rx (: bos
,@http_URL
(? (: "#" ,fragment))
eos)))
(define abs_path_with_frag (rx (: bos
(submatch ,abs_path)
(? (: "?" (submatch ,query)))
(? (: "#" ,fragment))
eos)))
(define Request-URI (rx (| ,@http_URL_with_frag ,@abs_path_with_frag)))
;;; parse a HTTP 1.1 Request_URI
;;;
;;; return matches of regexps host, port, abs_path, query;
;;;
;;; If request-uri is a relative URI, host and port are #f;
;;; port and query are also #f if they are not given.
;;; If there's no abs_path given, or abs_path is "/", path is the empty list;
;;; otherwise it is a list containing the path's segments.
;;;
;;; Caution: parse-url doesn't unescape anything yet!
(define (parse-url request-uri)
(cond
((regexp-search abs_path_with_frag request-uri)
=> (lambda (match)
(let ((path (split-abs-path (match:substring match 1)))
(query (match:substring match 2)))
(values #f #f path query))))
((regexp-search http_URL_with_frag request-uri)
=>(lambda (match)
(let ((host (match:substring match 1))
(port (match:substring match 2))
(path (split-abs-path (match:substring match 3)))
(query (match:substring match 4)))
(values host port path query))))
(else
(fatal-syntax-error "Request-URI syntactically faulty"))))
;;; split the string abs-path at slashes, return list of 'segments' (see RegExp definition above).
;;;
;;; SPLIT-PATH assumes abs-path if either #f or matches the RegExp abs_path,
;;; no checks are done.
;;;
;;; Remark: abs_path allows for strings containing several consecutive slashes;
;;; SPLIT-ABS-PATH treats them as one slash.
;;; (e.g., "/foo///bar//baz" => ("foo" "bar" "baz"))
;;;
;;; Note: we have to differentiate between paths with trailing
;;; slash(es) and paths without and hand that information over
;;; to the request handler. (See
;;; http://httpd.apache.org/docs-2.0/misc/rewriteguide.html ->
;;;"Trailing Slash problem" for the reasons.)
;;; If there is one or more trailing slash(es) the last element of the
;;; returned list will be an empty string.
;;; (e.g., "/foo///bar//baz//" => ("foo" "bar" "baz" ""))
(define (split-abs-path abs-path)
(if abs-path
(let* ((trailing-slash (char=? #\/ (string-ref abs-path (- (string-length abs-path) 1))))
(last-element (if trailing-slash '("") '())))
(regexp-fold-right
(rx (+ (~ ("/"))))
(lambda (match i res)
(cons (match:substring match 0) res))
last-element
abs-path))
'()))
;;; record type HTTP-URL for Request_URIs
;;;
;;; The HOST slot is a non-empty-string or #f.
;;;
;;; The PORT slot is an integer or #f.
;;;
;;; The PATH slot is a list of strings containing the Request_URI's
;;; path split at slashes and unescaped. If the Request_URI's path
;;; ends with a slash, an empty string is inserted as the last element
;;; of the list.
;;; (e.g., "/foo///bar//baz" => ("foo" "bar" "baz"))
;;; (e.g., "/foo///bar//baz//" => ("foo" "bar" "baz" ""))
;;;
;;; The QUERY slot is an non-empty-string, still in its escaped
;;; representation, or #f.
;;; Caution: the path slot of a http-url record has already been
;;; UNESCAPED; don't unescape it a second time!
;;; The query slot is still in its escaped representation.
(define-record-type http-url :http-url
(make-http-url server path search fragment-identifier)
(make-http-url host port path query)
http-url?
(server http-url-server) ; Initial //anonymous@clark.lcs.mit.edu:80/
(path http-url-path) ; Rest of path, split at slashes & decoded.
(search http-url-search)
(fragment-identifier http-url-fragment-identifier))
(host http-url-host)
(port http-url-port)
(path http-url-path)
(query http-url-query))
(define-record-discloser :http-url
(lambda (url)
(list 'http-url
(http-url->string url))))
;;; Is http-url of the form http_URL, i.e. absolute?
(define (absolute-url? http-url)
(http-url-host http-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
;;; URI's path split at slashes. Optional parts of the URI, when
;;; missing, are specified as #f. If <scheme> is "http", then the
;;; other three parts can be passed to PARSE-HTTP-URL, which parses
;;; them into a HTTP-URL record. All strings come back from the URI
;;; parser encoded. SEARCH and FRAG-ID are left that way; this parser
;;; decodes the path elements.
;;;
;;; Returns a HTTP-URL record, if possible. Otherwise
;;; FATAL-SYNTAX-ERROR is called.
;;; parse a HTTP 1.1. Request_URI into a http-url record
(define (parse-http-url path search frag-id)
(let ((uh (parse-server path default-http-server)))
(if (or (server-user uh) (server-password uh))
(fatal-syntax-error
"HTTP URL's may not specify a user or password field" path))
(define (url-string->http-url uri-string)
(receive (host port path query)
(parse-url uri-string)
(let ((portnumber (and port (string->number port)))
(unescaped-path (map unescape path)))
(make-http-url host portnumber unescaped-path query))))
(make-http-url uh (map unescape-uri (cdddr path)) search frag-id)))
;;; Unparse a http-url record into its corresponding Request_URI
(define (parse-http-url-string string)
(call-with-values
(lambda () (parse-uri string))
(lambda (scheme path search frag-id)
(if (string=? scheme "http")
(parse-http-url path search frag-id)
(fatal-syntax-error "not an HTTP URL" path)))))
;;; The following holds (apart from multiple slashes in the path,
;;; which are removed by url-string->http-url):
;;; (http-url->url-string (url-string->http-url <request-uri-string>)) == <request-uri-string>
;;; Default http port is 80.
(define default-http-server (make-server #f #f #f "80"))
(define (http-url->url-string http-url)
(let* ((host (http-url-host http-url))
(scheme-and-host-string
(if host
(string-append "http://" host)
""))
;;; Unparse.
(port (http-url-port http-url))
(port-string
(if port
(string-append ":" (number->string port))
""))
(define (http-url->string url)
(string-append "http://"
(server->string (http-url-server url))
"/"
(uri-path->uri (map escape-uri (http-url-path url)))
(cond ((http-url-search url) =>
(lambda (s) (string-append "?" s)))
(else ""))
(cond ((http-url-fragment-identifier url) =>
(lambda (fi) (string-append "#" fi)))
(else ""))))
(path (http-url-path http-url))
(path-string
(fold-right
(lambda (segment res)
(string-append "/" (escape-segment segment) res))
""
path))
(query (http-url-query http-url))
(query-string (if query
(string-append "?" query)
"")))
(string-append scheme-and-host-string port-string path-string query-string)))
;;; Unparse the http-url-path field of an http-url record into its
;;; corresponding part of the Request_URI
(define (http-url-path->path-string http-url-path)
(fold-right
(lambda (segment res)
(string-append "/" (escape-segment segment) res))
""
http-url-path))
;;; decoding and encoding Request-URIs:
;;; to decode Request-URIs use UNESCAPE from uri.scm
;;; encode Request-URIs:
;;; Each component of a URI may have its own set of characters that are reserved,
;;; -> differentiate between components.
;;; not allowed within component 'segment' in 'abs_path'
(define segment-reserved-and-excluded (rx (~ ,unreserved ,pchar-charset (";"))))
;;; not allowed within component 'query'
(define query-reserved-and-excluded (rx (~ ,unreserved ,reserved )))
;;; encode 'abs_path' portion of a URI:
;;; use SPLIT-PATH to split abs_path into its segments,
;;; then apply ESCAPE-SEGMENT to the segments.
(define (escape-segment segment)
(escape segment segment-reserved-and-excluded))
;;; encode 'query' portion of a URI
(define (escape-query query)
(escape query query-reserved-and-excluded))
;;; encode something we don't know: escape all but the unreserved characters.
(define (escape-not-unreserved-chars something)
(escape something (rx (~ ,unreserved))))
;; Appendix A of RFC 2396
;;
;A. Collected BNF for URI
; URI-reference = [ absoluteURI | relativeURI ] [ "#" fragment ]
; absoluteURI = scheme ":" ( hier_part | opaque_part )
; relativeURI = ( net_path | abs_path | rel_path ) [ "?" query ]
; hier_part = ( net_path | abs_path ) [ "?" query ]
; opaque_part = uric_no_slash *uric
; uric_no_slash = unreserved | escaped | ";" | "?" | ":" | "@" |
; "&" | "=" | "+" | "$" | ","
; net_path = "//" authority [ abs_path ]
; abs_path = "/" path_segments
; rel_path = rel_segment [ abs_path ]
; rel_segment = 1*( unreserved | escaped |
; ";" | "@" | "&" | "=" | "+" | "$" | "," )
; scheme = alpha *( alpha | digit | "+" | "-" | "." )
; authority = server | reg_name
; reg_name = 1*( unreserved | escaped | "$" | "," |
; ";" | ":" | "@" | "&" | "=" | "+" )
; server = [ [ userinfo "@" ] hostport ]
; userinfo = *( unreserved | escaped |
; ";" | ":" | "&" | "=" | "+" | "$" | "," )
; hostport = host [ ":" port ]
; host = hostname | IPv4address
; hostname = *( domainlabel "." ) toplabel [ "." ]
; domainlabel = alphanum | alphanum *( alphanum | "-" ) alphanum
; toplabel = alpha | alpha *( alphanum | "-" ) alphanum
; IPv4address = 1*digit "." 1*digit "." 1*digit "." 1*digit
; port = *digit
; path = [ abs_path | opaque_part ]
; path_segments = segment *( "/" segment )
; segment = *pchar *( ";" param )
; param = *pchar
; pchar = unreserved | escaped |
; ":" | "@" | "&" | "=" | "+" | "$" | ","
; query = *uric
; fragment = *uric
; uric = reserved | unreserved | escaped
; reserved = ";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" |
; "$" | ","
; unreserved = alphanum | mark
; mark = "-" | "_" | "." | "!" | "~" | "*" | "'" |
; "(" | ")"
; escaped = "%" hex hex
; hex = digit | "A" | "B" | "C" | "D" | "E" | "F" |
; "a" | "b" | "c" | "d" | "e" | "f"
; alphanum = alpha | digit
; alpha = lowalpha | upalpha
; lowalpha = "a" | "b" | "c" | "d" | "e" | "f" | "g" | "h" | "i" |
; "j" | "k" | "l" | "m" | "n" | "o" | "p" | "q" | "r" |
; "s" | "t" | "u" | "v" | "w" | "x" | "y" | "z"
; upalpha = "A" | "B" | "C" | "D" | "E" | "F" | "G" | "H" | "I" |
; "J" | "K" | "L" | "M" | "N" | "O" | "P" | "Q" | "R" |
; "S" | "T" | "U" | "V" | "W" | "X" | "Y" | "Z"
; digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" |
; "8" | "9"

496
scheme/packages.scm
View File

@ -3,11 +3,6 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 2000-2002 by Martin Gasbichler.
;;; Copyright (c) 1998-2001 by Eric Marsden.
;;; Copyright (c) 2005-2006 by Norbert Freudemann.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
@ -20,6 +15,7 @@
(define-interface htmlout-interface
(export emit-tag
emit-empty-tag
emit-close-tag
emit-p
@ -30,7 +26,10 @@
with-tag*
escape-html
emit-text))
emit-text
emit-prolog
xmlnsdecl-attr))
(define-interface smtp-interface
(export smtp-send-mail
@ -50,37 +49,23 @@
rfc822-time->string))
(define-interface uri-interface
(export parse-uri
uri-escaped-chars
unescape-uri
escape-uri
split-uri
uri-path->uri
simplify-uri-path))
(export unescape
escape))
(define-interface url-interface
(export server?
make-server
server-user
server-password
server-host
server-port
parse-server
server->string
(export escape-not-unreserved-chars
escaped
http-url?
make-http-url
http-url-server
http-url-host
http-url-port
http-url-path
http-url-search
http-url-fragment-identifier
http-url-query
parse-http-url
parse-http-url-string
http-url->string))
absolute-url?
url-string->http-url
http-url->url-string
http-url-path->path-string))
(define-interface ftp-library-interface
(export copy-port->port-binary
@ -148,7 +133,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 lookup function
dns-lookup-mail-exchanger ; simple lookpu function
pretty-print-dns-message ; prints a human readable dns-msg
force-ip ; reruns a lookup until a ip is resolved
force-ip-list ; reruns a lookup until a list of ips is resolved
@ -161,25 +146,7 @@
host-fqdn
system-fqdn
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
dns-get-information
(network-protocol :syntax)
network-protocol?
@ -190,67 +157,38 @@
pretty-print-dns-message
make-message message? message-header message-questions message-answers
message? message-header message-questions message-answers
message-nameservers message-additionals message-source
set-message-source!
make-query-message make-simple-query-message
make-header header? header-id header-flags header-question-count
header-answer-count header-nameserver-count header-additional-count
header? header-flags header-question-count header-answer-count
header-nameserver-count header-additional-count
make-flags flags? flags-query-type flags-opcode flags-authoritative?
flags? flags-query-type flags-opcode flags-authoritative?
flags-truncated? flags-recursion-desired? flags-recursion-available?
flags-zero flags-response-code set-flags-response-code!
set-flags-authoritative! set-flags-recursion-available!
set-flags-truncated!
flags-zero flags-response-code
make-question question? question-name question-type question-class
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
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-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-soa
resource-record-data-soa?
resource-record-data-soa-mname
resource-record-data-soa-rname
@ -260,18 +198,6 @@
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?
@ -284,7 +210,6 @@
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
@ -327,150 +252,6 @@
(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
@ -546,7 +327,8 @@
version->string))
(define-interface httpd-responses-interface
(export make-response response?
(export http-version
make-response response?
response-code
response-message
response-seconds
@ -563,6 +345,7 @@
make-writer-body writer-body?
make-reader-writer-body reader-writer-body?
make-redirect-body redirect-body? redirect-body-location
no-body?
display-http-body
status-code?
@ -575,6 +358,10 @@
make-error-response
make-redirect-response))
(define-interface httpd-handler-lib-interface
(export get-socket-host-string
read-message-body))
(define-interface httpd-basic-handlers-interface
(export make-predicate-handler
make-path-predicate-handler
@ -630,7 +417,7 @@
(define-structure sunet-version (export sunet-version-identifier)
(open scheme)
(begin
(define sunet-version-identifier "2.1")))
(define sunet-version-identifier "2.0")))
;; Net protocols and formats
@ -674,19 +461,14 @@
(define-structure uri uri-interface
(open scheme-with-scsh
(subset srfi-13 (string-index string-index-right string-fold string-join))
let-opt
receiving
ascii
bitwise
field-reader-package)
bitwise)
(files (lib uri)))
(define-structure url url-interface
(open scheme-with-scsh
define-record-types
receiving
(subset srfi-13 (string-index))
(subset srfi-1 (fold-right))
uri
httpd-errors)
(files (lib url)))
@ -741,22 +523,21 @@
(define-structure dns dns-interface
(open scheme-with-scsh
(subset srfi-1 (filter reverse! delete lset-difference lset-union
fold fold-right concatenate))
(subset srfi-1 (filter reverse! delete lset-difference lset-union))
tables
ascii
formats
signals
finite-types
define-record-types
random
queues
conditions
handle
sort
threads
locks
ips
srfi-27)
ips)
(files (lib dns)))
(define-structure ips ips-interface
@ -805,7 +586,7 @@
(open scheme-with-scsh
format-net
sigevents
(subset srfi-13 (string-join))
(subset srfi-13 (string-join string-skip string-trim-both))
dns
let-opt ; :optional
locks
@ -816,159 +597,6 @@
(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
@ -1001,7 +629,6 @@
rfc822
handle ; ignore-errors
conditions ; condition-stuff
uri
url
format-net
rate-limit ; rate-limiting stuff
@ -1019,6 +646,7 @@
httpd-logging
httpd-requests
httpd-responses
httpd-handler-lib
sunet-version
)
@ -1055,8 +683,7 @@
i/o ; make-null-output-port
locks
receiving
uri ; uri-path->uri
url ; http-url-path
url ; http-url-path, http-url-path->path-string
httpd-requests ; request record
httpd-responses
formats
@ -1080,6 +707,8 @@
(define-structure httpd-responses httpd-responses-interface
(open scheme
(subset scsh (format-date write-string time date))
url
htmlout
syslog
define-record-types
finite-types
@ -1089,12 +718,26 @@
httpd-read-options)
(files (httpd response)))
(define-structure httpd-handler-lib httpd-handler-lib-interface
(open scheme-with-scsh
crlf-io ; read-crlf-line
rfc822 ;read-rfc822-headers
format-net ;format-internet-host-address
(subset srfi-13 (string-trim-both string-trim string-prefix? string-reverse string-contains string-take))
handle-fatal-error
sunet-utilities ;get-header
httpd-requests
httpd-responses
httpd-errors)
(files (httpd handler-lib)))
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
(open scheme-with-scsh
rfc822
httpd-requests ; REQUEST record type, v0.9-request
(subset srfi-1 (fold-right))
(subset srfi-13 (string-trim string-prefix-ci?))
sunet-utilities
httpd-responses
httpd-errors
)
@ -1107,6 +750,7 @@
httpd-requests
httpd-responses
httpd-errors
httpd-handler-lib
httpd-basic-handlers
httpd-read-options
url
@ -1127,7 +771,7 @@
httpd-requests ; v0.9-request
httpd-responses
httpd-logging ; http-log
uri ; UNESCAPE-URI
httpd-handler-lib
htmlout ; Formatted HTML output
pp
(subset srfi-13 (string-skip))
@ -1136,7 +780,8 @@
handle ; IGNORE-ERROR
parse-html-forms ; PARSE-HTML-FORM-QUERY
threads ; SLEEP
sunet-utilities ; GET-HEADER
sunet-utilities
handle-fatal-error
)
(files (httpd seval)))
@ -1174,7 +819,7 @@
(define-structure httpd-cgi-handlers httpd-cgi-handlers-interface
(open scheme-with-scsh
(subset srfi-1 (alist-delete))
(subset srfi-13 (string-prefix? string-index string-trim substring/shared))
(subset srfi-13 (string-prefix? string-index string-trim substring/shared string-join))
rfc822
crlf-io ; WRITE-CRLF
uri
@ -1184,6 +829,7 @@
httpd-responses
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
httpd-errors ; HTTP-ERROR
httpd-handler-lib
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
sunet-version
formats

25
web-server/start-extended-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 module-system/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 sunet-2.1/load.scm -dm -o http-test -e main -s "$0" "$@"
!#
(define-structure http-test
@ -111,11 +111,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
(else
(error "Internal error, option not found" option alist))))
(define (become-nobody-if-root)
(cond ((zero? (user-uid))
(set-gid (->gid "nobody"))
(set-uid (->uid "nobody")))))
(define (main args)
(with-cwd
(file-name-directory (car args))
@ -126,6 +121,9 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
(log-file-name . "/tmp/httpd.log")
(requests . 5)))
(options (make-options-from-args (cdr args) default-options)))
(cond ((zero? (user-uid))
(set-gid (->gid "nobody"))
(set-uid (->uid "nobody"))))
(format #t "Going to run Webserver with:
htdocs-dir: ~a
@ -147,19 +145,15 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
with-simultaneous-requests (lookup-option options 'requests)
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)
(list (cons "h" (home-dir-handler "public_html"))
(cons "seval" seval-handler)
;; You may want to adapt this to your site.
;; call like http://localhost:8080/man/man?ssh(1)
(cons "man" (rman-handler 'man
'nroff
"/usr/X11R6/bin/rman"
"/usr/bin/rman"
"/usr/bin/zcat"
#f "man?%s(%s)"
"Generated by rman-gateway"))
@ -169,9 +163,8 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
"Generated by info-gateway"))
(cons "cgi-bin" (cgi-handler
(lookup-option options 'cgi-bin-dir))))
(tilde-home-dir-handler "public_html"
(rooted-file-or-directory-handler
(lookup-option options 'htdocs-dir)))))))))
(rooted-file-or-directory-handler
(lookup-option options 'htdocs-dir))))))))
))
;; EOF

44
web-server/start-surflet-server → start-surflet-server
View File

@ -1,7 +1,7 @@
#!/bin/sh
echo "Loading..."
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" "$@"
exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -e main -s "$0" "$@"
!#
(define-structure surflet-server
@ -11,8 +11,10 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
httpd-make-options
httpd-basic-handlers
httpd-file-directory-handlers
httpd-cgi-handlers
httpd-seval-handlers
; cgi-server
; seval-handler
; rman-gateway
; info-gateway
surflet-handler
surflet-handler/options
let-opt
@ -27,7 +29,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
(format #f
"Usage: start-surflet-server
[-h DIR | --htdocs-dir=DIR] [-s DIR | --surflet-dir=DIR]
[--cgi-bin-dir=DIR]
[-i DIR | --images-dir=DIR] [-p NUM | --port=NUM]
[-l FILE | --log-file-name=FILE] [-r NUM | --requests=NUM]
[--help]
@ -35,14 +36,14 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
with
htdocs-dir directory of html files (default: root/htdocs)
surflet-dir directory of SUrflet files (default: root/surflets)
cgi-bin-dir directory of cgi files (default: root/cgi-bin)
images-dir directory of images files (default: root/img)
port port server is listening to (default: 8080)
port port server is listening to (default: 8008)
log-file-name directory where to store the logfile in CLF
(default: /tmp/httpd.log)
requests maximal amount of simultaneous requests (default 5)
--help show this help
"))
NOTE: This is the SUrflet-server. It does not support cgi-bin.~%"))
(define (display-usage)
(display (usage) (current-error-port))
@ -82,9 +83,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
(surflet-dir-option
(option '(#\s "surflet-dir") #t #f
(absolute-file-option-proc 'surflet-dir)))
(cgi-bin-dir-option
(option '(#\c "cgi-bin-dir") #t #f
(absolute-file-option-proc 'cgi-bin-dir)))
(images-dir-option
(option '(#\i "images-dir") #t #f
(absolute-file-option-proc 'images-dir)))
@ -103,7 +101,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
(display-usage)))))
(args-fold arg-list
(list htdocs-dir-option surflet-dir-option
cgi-bin-dir-option
images-dir-option port-option
log-file-name-option requests-option
help-option)
@ -129,40 +126,36 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
(define (server . args)
(if (pair? args)
(main `(main ,@(car args)))
(main (list (cwd)))))
(main '(main))))
(define (become-nobody-if-root)
(cond ((zero? (user-uid))
(set-gid (->gid "nobody"))
(set-uid (->uid "nobody")))))
(define (main args)
(with-cwd
(file-name-directory (car args))
(let* ((default-options
`((htdocs-dir . ,(absolute-file-name "root/htdocs"))
(surflet-dir . ,(absolute-file-name "root/surflets"))
(cgi-bin-dir . ,(absolute-file-name "root/cgi-bin"))
(images-dir . ,(absolute-file-name "root/img"))
(port . 8080)
(port . 8008)
(log-file-name . "/tmp/httpd.log")
(requests . 5)))
(options (make-options-from-args (cdr args) default-options)))
(cond ((zero? (user-uid))
(set-gid (->gid "nobody"))
(set-uid (->uid "nobody"))))
(format #t "Going to run SUrflet server with:
htdocs-dir: ~a
surflet-dir: ~a
cgi-bin-dir: ~a
images-dir: ~a
port: ~a
log-file-name: ~a
a maximum of ~a simultaneous requests, syslogging activated,
and home-dir-handler (public_html) activated.
NOTE: This is the SUrflet server. It does not support cgi.
"
(lookup-option options 'htdocs-dir)
(lookup-option options 'surflet-dir)
(lookup-option options 'cgi-bin-dir)
(lookup-option options 'images-dir)
(lookup-option options 'port)
(lookup-option options 'log-file-name)
@ -175,7 +168,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
with-simultaneous-requests (lookup-option options 'requests)
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"
@ -183,8 +175,7 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
with-request-handler
(alist-path-dispatcher
(list
(cons "cgi-bin" (cgi-handler (lookup-option options 'cgi-bin-dir)))
(cons "seval" seval-handler)
(cons "h" (home-dir-handler "public_html"))
(cons "source" (rooted-file-or-directory-handler
(lookup-option options 'surflet-dir)
(with-file-name->content-type
@ -198,9 +189,8 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
(cons "surflet" (surflet-handler
(with-surflet-path
(lookup-option options 'surflet-dir)))))
(tilde-home-dir-handler "public_html"
(rooted-file-or-directory-handler
(lookup-option options 'htdocs-dir)))))))))
(rooted-file-or-directory-handler
(lookup-option options 'htdocs-dir))))))))
))
;; EOF

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

@ -1,6 +1,6 @@
#!/bin/sh
echo "Loading..."
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" "$@"
exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e main -s "$0" "$@"
!#
(define-structure http-test
@ -140,10 +140,6 @@ exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load
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)))

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

@ -9,24 +9,19 @@
<ul>
<li><a href="/sunet-manual/index.html">SUnet release manual</a></li>
<li><a href="/cgi-bin/comments.sh">A small CGI script</a></li>
<li><a href="/index-surflet.html">SUrflets homepage</a>
(<code>start-surflet-server</code> only)</li>
<li><a href="/index-surflet.html">SUrflets homepage</a></li>
<li><a href="seval.html">Computing Scheme Forms
Interactively</a></li>
<li><a href="files/text.txt">Text file</a></li>
<li><a href="files">Directory</a></li>
<li><a href="files/zipped.gz">Compressed File</a></li>
<li><a href="index.html">This file</a></li>
<li><a href="man/man?man(1)">man ls</a>
(<code>start-extended-web-server</code> only)</li>
<li><a href="info/info?(info.info)Top">Info page for Info</a>
(<code>start-extended-web-server</code> only)</li></li>
</ul>
<br>
<hr>
<!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
<!-- hhmts start -->
Last modified: Mon May 17 10:13:07 MST 2004
Last modified: Wed Apr 23 09:25:58 MST 2003
<!-- hhmts end -->
</body>
</html>

4
web-server/root/surflets/add-html.scm
View File

@ -28,7 +28,7 @@
(p (url "/" "Return to main menu") (br)
(url "add-html.scm" "Start new calculation."))))))))
(let* ((bindings (form-query-list
(http-url-search (surflet-request-url result))))
(http-url-query (surflet-request-url result))))
(number (string->number
(extract-single-binding "number" bindings))))
(if number
@ -53,7 +53,7 @@
(a (@ (href "javascript:history.go(-2)")) "New calculation (same session)")(br)
(a (@ (href ,new-url)) "Close this session")))))))
;; How to clear session data and go to another HTML page:
(send-error (status-code moved-temp) req
(send-error (status-code temp-redirect) req
"/" "/")
))
; ))

6
web-server/root/surflets/add-raw.scm
View File

@ -2,7 +2,7 @@
(open surflet-requests ; SURFLET-REQUEST-url
httpd-responses ; MAKE-RESPONSE
parse-html-forms ; PARSE-HTML-FORM-QUERY
url ; HTTP-url-SEARCH
url ; http-url-query
srfi-1 ; FILTER
surflet-handler/surflets ; SEND/SUSPEND, SEND/FINISH
surflet-handler/primitives ; MAKE-SURFLET-RESPONSE
@ -79,7 +79,7 @@
(let* ((title (if (pair? maybe-title) (car maybe-title) #f))
(result (send/suspend (make-get-number-page input-text title)))
(bindings (parse-html-form-query
(http-url-search (surflet-request-url result))))
(http-url-query (surflet-request-url result))))
(number (string->number
(extract-single-binding "number" bindings))))
(if number
@ -96,7 +96,7 @@
(send/suspend make-result-page)
;; This finishes the session and does a redirect to the root
;; page.
(send-error (status-code moved-temp) #f "/" "/"))
(send-error (status-code temp-redirect) #f "/" "/"))
))

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

@ -8,7 +8,7 @@
)
(begin
(define (get-option-change update-text options)
(define (get-option-change return-address update-text options)
(send-html/suspend
(lambda (new-url)
`(html
@ -31,12 +31,14 @@
(td ,submit-button))))
options)))
(hr)
(p (url "admin.scm" "Return to adminstration menu.") (br)
(p (url ,(return-address new-url) "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"))
@ -46,9 +48,11 @@
(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 update-text options))
(req (get-option-change return-address 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
@ -70,6 +74,11 @@
(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 occurred while generating the profiling results"
`(p "An error occured 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 occurred while generating the profiling results picture."
`(p "An error occured 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/finish (main-page)))
(send-html (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 (input-field operator-string)
(lambda (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 (input-field operator-string)
(lambda (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 occurred above. Best explained by the use above.
;;; over two cases occured above. Best explained by the use above.
(define (check-bounded-number-field class input positiv selector boundary)
(if (or (not input)
(<= input 0))