move global variables in httpd-logging to preserved-thread-fluids

revision 1.38
date: 2002/09/02 09:02:27;  author: sperber;  state: Exp;  lines: +1 -5
Remove crud from SMTP-INTERFACE.

which was accidentally backed out by:

revision 1.40
date: 2002/09/02 14:34:31;  author: interp;  state: Exp;  lines: +7 -2
make MY-REPORTED-FQDN fit for lots of virtual hosts

.gitignore

@@ -26,3 +26,5 @@ _$*
 *.ln
 core
 # CVS default ignores end
+test-packages.scm 
+test

COPYING

@@ -1,6 +1,7 @@
 Copyright (c) 1995-2000 by Olin Shivers.
-Copyright (c) 1996-2000 by Mike Sperber
-Copyright (c) 1999-2000 by Martin Gasbichler.
+Copyright (c) 1996-2001 by Mike Sperber.
+Copyright (c) 1999-2001 by Martin Gasbichler.
+Copyright (c) 1998-2001 by Eric Marsden.
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

ChangeLog

@@ -1,27 +0,0 @@
-1997-12-01  Michael Sperber [Mr. Preprocessor]  <sperber@informatik.uni-tuebingen.de>
-
-	* smtp.scm, parse-forms.scm: now 0.5.1-conformant
-
-Mon Dec  2 10:41:09 1996  Michael Sperber [Mr. Preprocessor]  <sperber@informatik.uni-tuebingen.de>
-
-	* ChangeLog: released 1.0beta2.
-
-	* htmlout.scm: Added escape-html and emit-text.
-
-	* http-core.scm: Made maintainer, domain name, and port
- 	configurable.
-
-	* everything: Commented date routines back in.
-
-	* httpd-access-control.scm: New file.  Provides rudimentary access
- 	control.
-	
-	* httpd-basic-handlers.scm: Added directory index serving.  See
- 	comments in that file and in su-httpd.txt.
-
-	* info-gateway.scm: Added GNU info gateway.
-
-	* everything: Things now work under scsh 0.4.4.
-
-	* ChangeLog: started this file.
-

Makefile

@@ -0,0 +1,47 @@
+SHELL = /bin/sh
+
+version_id = 1.0
+
+TEMPDIR = /tmp
+
+sunet_files = Readme \
+	cgi-script.scm \
+	cgi-server.scm \
+	conditionals.scm \
+	crlf-io.scm \
+	htmlout.scm \
+	http-top.scm \
+	httpd/access-control.scm \
+	httpd/core.scm \
+	httpd/error.scm \
+	httpd/handlers.scm \
+	info-gateway.scm \
+	rman-gateway.scm \
+	modules.scm \
+	parse-forms.scm \
+	program-modules.scm \
+	rfc822.scm \
+	scheme-program-server.scm \
+	server.scm \
+	seval.scm \
+	smtp.scm \
+	stringhax.scm \
+	su-httpd.txt \
+	toothless.scm \
+	uri.scm \
+	url.scm
+
+
+sunet-$(version_id).tar.gz: $(sunet_files)
+	sunet_root=`pwd`; \
+	mkdir $(TEMPDIR)/sunet-$(version_id); \
+	cp $(sunet_files) $(TEMPDIR)/sunet-$(version_id); \
+	cd $(TEMPDIR); \
+	tar czf sunet-$(version_id).tar.gz sunet-$(version_id); \
+	mv sunet-$(version_id).tar.gz $$sunet_root; \
+	rm -rf sunet-$(version_id)
+
+.PHONY: tags
+tags:
+	find -name "*.scm" | etags -
+

Readme

@@ -43,3 +43,5 @@ into a realistic full-blown package, but I'll gladly accept patches
 and suggestions for the other parts of the net package.
 
     -Mike
+
+And: See the doc directory for further informations.

cgi-server.scm

@@ -1,279 +0,0 @@
-;;; Server support for NCSA's WWW Common Gateway Interface -*- Scheme -*-
-;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
-
-;;; Imports and non-R4RS'isms
-;;;     "\r" in string for carriage-return.
-;;; 	format
-;;;	string hacks
-;;;	URI, URL record structs, parsers, and unparsers
-;;;	write-crlf
-;;;	scsh syscalls
-;;;	? for COND
-;;;	SWITCH conditional
-;;;	RFC822 header parsing
-;;;	HTTP request record structure
-;;;	HTTP-ERROR & reply codes
-;;;	Basic path handler support (for ncsa-handler)
-
-;;; PROBLEMS: 
-;;;   - The handlers could be made -- closed over their parameters
-;;;     (e.g., root vars, etc.)
-
-;;; This code provides a path-handler for the HTTP server that implements 
-;;; a CGI interface to external programs for doing HTTP transactions.
-
-;;; About HTML forms
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; This info is in fact independent of CGI, but important to know about, 
-;;; as many CGI scripts are written for responding to forms-entry in
-;;; HTML browsers.
-;;;
-;;; The form's field data are turned into a single string, of the form
-;;;     name=val&name=val
-;;; where the <name> and <val> parts are URI encoded to hide their
-;;; &, =, and + chars, among other things. After URI encoding, the
-;;; space chars are converted to + chars, just for fun. It is important
-;;; to encode the spaces this way, because the perfectly general %xx escape
-;;; mechanism might be insufficiently confusing. This variant encoding is
-;;; called "form-url encoding."
-;;;
-;;; If the form's method is POST,
-;;;     Browser sends the form's field data in the entity block, e.g.,
-;;;     "button=on&ans=yes". The request's Content-type: is application/
-;;; 	x-www-form-urlencoded, and the request's Content-length: is the
-;;; 	number of bytes in the form data.
-;;;
-;;; If the form's method is GET,
-;;;     Browser sends the form's field data in the URL's <search> part.
-;;;     (So the server will pass to the CGI script as $QUERY_STRING,
-;;;     and perhaps also on in argv[]).
-;;;
-;;; In either case, the data is "form-url encoded" (as described above).
-
-;;; ISINDEX queries:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; (Likewise for ISINDEX URL queries from browsers.)
-;;; Browser url-form encodes the query (see above), which then becomes the
-;;; ?<search> part of the URI. (Hence the CGI script will split the individual
-;;; fields into argv[].)
-
-
-;;; CGI interface:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
-;;; - If it contains no raw "=" chars, it is split at "+" chars. The
-;;;   substrings are URI decoded, and become the elts of argv[].
-;;; - The CGI script is run with stdin hooked up to the socket. If it's going
-;;;   to read the entity, it should read $CONTENT_LENGTH bytes worth.
-;;; - A bunch of env vars are set; see below.
-;;; - If the script begins with "nph-" its output is the entire reply.
-;;;   Otherwise, it replies to the server, we peel off a little header
-;;;   that is used to construct the real header for the reply.
-;;; See the "spec" for further details.
-;;;
-;;; The "spec" also talks about PUT, but when I tried this on a dummy script,
-;;; the NSCA httpd server generated buggy output. So I am only implementing
-;;; the POST and GET ops; any other op generates a "405 Method not allowed"
-;;; reply.
-
-;;; Parameters
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; path for scripts 
-(define cgi-default-bin-path "/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin")
-
-
-;;; The path handler for CGI scripts. (car path) is the script to run.
-
-(define (cgi-handler bin-dir)
-  (lambda (path req)
-    (if (pair? path)	; Got to have at least one elt.
-        (let* ((prog (car path))
-
-	       (filename (or (dotdot-check bin-dir (list prog))
-			     (http-error http-reply/bad-request req
-					 (format #f "CGI scripts may not contain \"..\" elements."))))
-
-	       (nph? (string-suffix? "-nph" prog))	; PROG end in "-nph" ? 
-
-	       (search (http-url:search (request:url req)))	; Compute the
-	       (argv (if (and search (not (index search #\=)))	; argv list.
-		         (split-and-decode-search-spec search)
-		         '()))
-
-	       (env (cgi-env req bin-dir (cdr path)))
-
-	       (doit (lambda ()
-		       (apply exec/env filename env argv)
-		       (http-error http-reply/bad-request req
-				   (format #f "Could not execute CGI script ~a."
-					   filename)))))
-
-	  (http-log "search: ~s, argv: ~s~%" search argv)
-	  (switch string=? (request:method req)
-            (("GET" "POST")		; Could do others also.
-	     (if nph?
-		 (wait (fork doit))
-		 (cgi-send-reply (run/port* doit) req)))
-
-	    (else (http-error http-reply/method-not-allowed req))))
-	       
-	(http-error http-reply/bad-request req "Empty CGI script"))))
-
-
-(define (split-and-decode-search-spec s)
-  (let recur ((i 0))
-    (? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
-					     (recur (+ j 1)))))
-       (else (list (unescape-uri s i (string-length s)))))))
-
-
-;;; Compute the CGI scripts' process environment by adding the standard CGI
-;;; environment var bindings to the current process env -- return result
-;;; as an alist.
-;;;
-;;; You are also supposed to add the headers as env vars in a particular
-;;; format, but are allowed to bag it if the environment var storage 
-;;; requirements might overload the OS. I don't know what you can rely upon
-;;; in Unix, so I am just bagging it, period.
-;;;
-;;; Suppose the URL is
-;;;   //machine/cgi-bin/test-script/foo/bar?quux%20a+b=c
-;;; then:
-;;;   PATH_INFO -- extra info after the script-name path prefix. "/foo/bar"
-;;;   PATH_TRANSLATED -- non-virtual version of above.  "/u/Web/foo/bar/"
-;;;   SCRIPT_NAME virtual path to script "/cgi-bin/test-script"
-;;;   QUERY_STRING -- not decoded "quux%20a+b=c"
-;;; The first three of these vars are *not* encoded, so information is lost
-;;; if the URL's path elements contain encoded /'s (%2F). CGI loses.
-
-(define (cgi-env req bin-dir path-suffix)
-  (let* ((sock (request:socket req))
-	 (raddr (socket-remote-address sock))
-
-	 (headers (request:headers req))
-
-	 ;; Compute the $PATH_INFO and $PATH_TRANSLATED strings.
-	 (path-info (uri-path-list->path 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-list->path script-path)))
-
-    (if (not request-invariant-cgi-env)
-	(initialise-request-invariant-cgi-env))
-
-    (receive (rhost rport)
-	     (socket-address->internet-address raddr)
-      (receive (lhost lport)
-               (socket-address->internet-address (socket-local-address sock))
-
-	`(("SERVER_PROTOCOL" . ,(version->string (request:version req)))
-	  ("SERVER_PORT"     . ,(number->string lport))
-	  ("REQUEST_METHOD"  . ,(request:method req))
-
-	  ("PATH_INFO"       . ,path-info)
-	  ("PATH_TRANSLATED" . ,path-translated)
-	  ("SCRIPT_NAME"     . ,script-name)
-
-	  ("REMOTE_HOST"  . ,(host-info:name (host-info raddr)))
-	  ("REMOTE_ADDR"  . ,(internet-address->dotted-string rhost))
-
-	  ;; ("AUTH_TYPE" . xx)			; Random authentication
-	  ;; ("REMOTE_USER" . xx)		; features I don't understand.
-	  ;; ("REMOTE_IDENT" . xx)
-
-	  ,@request-invariant-cgi-env	; Stuff that never changes (see below).
-
-	  ,@(? ((http-url:search (request:url req)) =>
-                (lambda (srch) `(("QUERY_STRING" . ,srch))))
-	       (else '()))
-
-	  ,@(? ((get-header headers 'content-type) =>
-                (lambda (ct) `(("CONTENT_TYPE" . ,ct))))
-	       (else '()))
-
-	  ,@(? ((get-header headers 'content-length) =>
-                (lambda (cl)	; Skip initial whitespace (& other non-digits).
-		  (let ((first-digit (char-set-index cl char-set:numeric))
-			(cl-len (string-length cl)))
-		    (if first-digit
-			`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
-			(http-error http-reply/bad-request
-				    req
-				    "Illegal Content-length: header.")))))
-
-	       (else '()))
-
-	  . ,(env->alist))))))
-
-(define request-invariant-cgi-env #f)
-(define (initialise-request-invariant-cgi-env)
-  (set! request-invariant-cgi-env
-	`(("PATH"              . ,(and (getenv "PATH") cgi-default-bin-path))
-	  ("SERVER_SOFTWARE"   . ,server/version)
-	  ("SERVER_NAME"       . ,(host-info:name (host-info (system-name))))
-	  ("GATEWAY_INTERFACE" . "CGI/1.1"))))
-	  
-
-(define (take n lis)
-  (if (zero? n) '()
-      (cons (car lis) (take (- n 1) (cdr lis)))))
-
-(define (drop n lis)
-  (if (zero? n) lis
-      (drop (- n 1) (cdr lis))))
-
-
-;;; Script's output for request REQ is available on SCRIPT-PORT.
-;;; The script isn't an "nph-" script, so we read the reply, and mutate
-;;; it into a real HTTP reply, which we then send back to the HTTP client.
-
-(define (cgi-send-reply script-port req)
-  (let* ((headers (read-rfc822-headers script-port))
-	 (ctype (get-header headers 'content-type))	; The script headers
-	 (loc   (get-header headers 'location))
-	 (stat  (let ((stat-lines (get-header-lines headers 'status)))
-		  (? ((not (pair? stat-lines))	    ; No status header.
-		      "200 The idiot CGI script left out the status line.")
-		     ((null? (cdr stat-lines)) 	    ; One line status header.
-		      (car stat-lines))
-		     (else			    ; Vas ist das?
-		      (http-error http-reply/internal-error req
-				  "CGI script generated multi-line status header")))))
-	 (out (current-output-port)))
-		      
-    (http-log "headers: ~s~%" headers)
-    ;; Send the reply header back to the client
-    ;; (unless it's a headerless HTTP 0.9 reply).
-    (unless (v0.9-request? req)
-      (format out "HTTP/1.0 ~a\r~%" stat)
-      (if ctype (format out "Content-type: ~a\r~%" ctype))
-      (if loc   (format out "Location: ~a\r~%" loc))
-      (write-crlf out))
-
-    (http-log "request:method=~a~%" (request:method req))
-    ;; Copy the reply body back to the client and close the script port
-    ;; (unless it's a bodiless HEAD transaction).
-    (unless (string=? (request:method req) "HEAD")
-      (copy-inport->outport script-port out)
-      (close-input-port script-port))))
-
-
-;;; This proc and its inverse should be in a general IP module.
-
-(define (internet-address->dotted-string num32)
-  (let* ((num24 (arithmetic-shift num32 -8))
-	 (num16 (arithmetic-shift num24 -8))
-	 (num08 (arithmetic-shift num16 -8))
-	 (byte0 (bitwise-and #b11111111 num08))
-	 (byte1 (bitwise-and #b11111111 num16))
-	 (byte2 (bitwise-and #b11111111 num24))
-	 (byte3 (bitwise-and #b11111111 num32)))
-    (string-append (number->string byte0) "." (number->string byte1) "."
-		   (number->string byte2) "." (number->string byte3))))

conditionals.scm

@@ -1,98 +0,0 @@
-;;; handy syntax
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-syntax when
-  (syntax-rules ()
-    ((when bool body1 body2 ...)
-     (if bool (begin body1 body2 ...)))))
-
-
-(define-syntax unless
-  (syntax-rules ()
-    ((unless bool body1 body2 ...)
-     (if (not bool) (begin body1 body2 ...)))))
-
-(define-syntax ?	; ? is synonym for COND.
-  (syntax-rules ()
-    ((? clause ...) (cond clause ...))))
-
-
-;;; Like CASE, but you specify the key-comparison procedure.
-;;; SWITCH evaluates its keys each time through the conditional.
-;;; SWITCHQ keys are not evaluated -- are simply constants.
-;;; (switchq string=? (vector-ref vec i)
-;;;   (("plus" "minus") ...)
-;;;   (("times" "div")  ...)
-;;;   (else ...))
-
-(define-syntax switchq
-  (syntax-rules ()
-    ((switchq compare key clause ...)
-     (let ((k key)			; Eval KEY and COMPARE
-	   (c compare))			; just once, then call %switch.
-       (%switchq c k clause ...)))))	; C, K are vars, hence replicable.
-
-(define-syntax %switchq
-  (syntax-rules (else)
-    ((%switchq compare key ((key1 ...) body1 body2 ...) rest ...)
-     (if (or (compare key 'key1) ...)
-	 (begin body1 body2 ...)
-	 (%switchq compare key rest ...)))
-
-    ((%switchq compare key ((key1 ...)) rest ...)	; Null body.
-     (if (not (or (compare key 'key1) ...))
-	 (%switchq compare key rest ...)))
-    
-    ((%switchq compare key (else body ...))
-     (begin body ...))
-
-    ((%switchq compare key) '#f)))
-
-
-(define-syntax switch
-  (syntax-rules ()
-    ((switch compare key clause ...)
-     (let ((k key)			; Eval KEY and COMPARE
-	   (c compare))			; just once, then call %switch.
-       (%switch c k clause ...)))))	; C, K are vars, hence replicable.
-
-(define-syntax %switch
-  (syntax-rules (else)
-    ((%switch compare key ((key1 ...) body1 body2 ...) rest ...)
-     (if (or (compare key key1) ...)
-	 (begin body1 body2 ...)
-	 (%switch compare key rest ...)))
-
-    ((%switch compare key ((key1 ...)) rest ...)	; Null body.
-     (if (not (or (compare key key1) ...))
-	 (%switch compare key rest ...)))
-    
-    ((%switch compare key (else body ...))
-     (begin body ...))
-
-    ((%switch compare key) '#f)))
-
-;;; I can't get this to work -- S48 complains "too many ...'s".
-;(define-syntax switchq
-;  (syntax-rules (else)
-;    ((switchq compare key clause ...)
-;     (letrec-syntax ((%switchq (syntax-rules (else)
-;			         ((%switchq compare key
-;					   ((key1 ...) body1 body2 ...) rest ...)
-;				  (if (or (compare key 'key1) ...)
-;				      (begin body1 body2 ...)
-;				      (%switchq compare key rest ...)))
-;
-;				 ; Null body.
-;				 ((%switchq compare key ((key1 ...)) rest ...)
-;				  (if (not (or (compare key 'key1) ...))
-;				      (%switchq compare key rest ...)))
-;    
-;			         ((%switchq compare key (else body ...))
-;				  (begin body ...))
-;
-;				 ((%switchq compare key) '#f))))
-;
-;        (let ((k key)			 ; Eval KEY and COMPARE
-;	      (c compare))		 ; just once, then call %switch.
-;	   (%switchq c k clause ...)))))); C, K are vars, hence replicable.

doc/html/index.html

@@ -0,0 +1,85 @@
+<HTML>
+<HEAD>
+<TITLE>The Scheme Underground Network Package</TITLE>
+</HEAD>
+
+<BODY>
+<H1>The Scheme Underground Network Package</H1>
+I have written a set of libraries for doing Net hacking from Scheme/scsh.
+It includes:
+<DL>
+<DT> An smtp client library.
+<DD> Forge mail from the comfort of your own Scheme process.
+
+<DT> rfc822 header library
+<DD> Read email-style headers. Useful in several contexts (smtp, http, etc.)
+
+<DT> Simple structured HTML output library
+<DD> Balanced delimiters, etc.
+
+<DT> The SU Web server
+<DD> This is a complete implementation of an HTTP 1.0 server in Scheme.
+     The server contains other standalone packages that may separately be of 
+     use:
+     <UL>
+     <LI> URI and URL parsers and unparsers.
+     <LI> A library to help writing CGI scripts in Scheme.
+     <LI> Server extensions for interfacing to CGI scripts.
+     <LI> Server extensions for uploading Scheme code.
+     </UL>
+    The server has three main design goals:
+    <DL>
+    <DT> Extensibility
+    <DD> The server is in fact nothing but extensions, using a mechanism
+	 called "path handlers" to define URL-specific services. It has a toolkit
+	 of services that can be used as-is, extended or built upon.
+	 User extensions have exactly the same status as the base services.
+
+	<P>
+	The extension mechanism allows for easy implementation of new services
+	without the overhead of the CGI interface. Since the server is written
+	on top of the Scheme shell, the full set of Unix system calls and
+	program tools is available to the implementor.
+
+    <DT> Mobile code
+    <DD> The server allows Scheme code to be uploaded for direct execution
+	 inside the server. The server has complete control over the code,
+	 and can safely execute it in restricted environments that do not
+	 provide access to potentially dangerous primitives (such as the
+	 "delete file" procedure.)
+
+
+    <DT> Clarity
+    <DD> I wrote this server to help myself understand the Web. It is voluminously
+	 commented, and I hope it will prove to be an aid in understanding the
+	 low-level details of the Web protocols.
+    </DL>
+
+    <P>
+    The S.U. server has the ability to upload code from Web clients and 
+    execute that code on behalf of the client in a protected environment.
+
+    <P>
+    Some <A HREF="su-httpd.html">simple documentation</A> on the server
+    is available.
+
+</DL>
+
+<H2>Obtaining the system</H2>
+The network code is available by
+<A HREF="ftp://ftp-swiss.ai.mit.edu/pub/scsh/contrib/net/net.tar.gz">ftp</A>.
+To run the server, you need our 0.4 release of 
+<A HREF="http://www-swiss.ai.mit.edu/scsh/scsh.html">scsh</A>
+which has just been released.
+
+Beyond actually running the server,
+the separate parser libraries and other utilites may be of use as separate
+modules.
+
+<ADDRESS><A HREF="http://www.ai.mit.edu/people/shivers/">Olin Shivers</A>
+       / <A HREF="plan-file">shivers@ai.mit.edu</A></ADDRESS>
+
+</BODY>
+</HTML>
+
+

doc/html/su-httpd.html

@@ -0,0 +1,482 @@
+<!-- check for *..* emphasis, etc., i.e., e.g. -->
+<HTML>
+<HEAD>
+<TITLE>The Scheme Underground Web system</TITLE>
+</HEAD>
+
+<BODY>
+<H1>The Scheme Underground Web System</H1>
+
+<ADDRESS><A HREF="http://www.ai.mit.edu/people/shivers/">Olin Shivers</A>
+       / <A HREF="plan-file">shivers@ai.mit.edu</A>
+</ADDRESS>
+July 1995
+
+<BLOCKQUOTE>
+Note: Netscape typesets description lists in a manner that makes the
+procedure descriptions below blur together, even in the absence of the
+HTML COMPACT attribute. You may just wish to print out a simple
+<A HREF="su-httpd.txt">ASCII version</A> of this note, instead.
+</BLOCKQUOTE>
+
+
+
+<!---------------------------------------------------------------------------->
+<H2>Introduction</H2>
+
+The
+<A HREF="http://www.ai.mit.edu/projects/su/su.html">Scheme underground</A>
+Web system is a package of
+<A HREF="http://www-swiss.ai.mit.edu/scheme-home.html">Scheme</A>
+code that provides
+utilities for interacting with the
+<A HREF="http://www.w3.org/">World-Wide Web</A>.
+This includes:
+<UL>
+<LI>  A Web server.
+<LI>  URI and URL parsers and un-parsers.
+<LI>  RFC822-style header parsers.
+<LI>  Code for performing structured html output
+<LI>  Code to assist in writing CGI Scheme programs
+      that can be used by any CGI-compliant HTTP server
+      (such as NCSA's httpd, or the S.U. Web server).
+</UL>
+
+ <P>
+The code can be obtained via
+<A HREF="ftp://ftp-swiss.ai.mit.edu/pub/scsh/contrib/net/net.tar.gz">
+anonymous ftp</A>
+and is implemented in
+<A HREF="http://www-swiss.ai.mit.edu/~jar/s48.html">Scheme 48</A>,
+using the system calls and support procedures of
+<A HREF="http://www-swiss.ai.mit.edu/scsh/scsh.html">scsh</A>,
+the Scheme Shell.
+The code was written to be clear and modifiable --
+it is voluminously commented and all non-R4RS dependencies are
+described at the beginning of each source file.
+
+ <P>
+I do not have the time to write detailed documentation for these packages.
+However, they are very thoroughly commented, and I strongly recommend
+reading the source files; they were written to be read, and the source
+code comments should provide a clear description of the system.
+The remainder of this note gives an overview of the server's basic
+architecture and interfaces.
+
+<H2>The Scheme Underground Web Server</H2>
+
+The server was designed with three principle goals in mind:
+<DL>
+<DT> Extensibility
+<DD> The server is designed to make it easy to extend the basic
+     functionality.  In fact, the server is nothing but extensions.  There is
+     no distinction between the set of basic services provided by the server
+     implementation and user extensions -- they are both implemented in
+     Scheme, and have equal status. The design is "turtles all the way down."
+
+
+<DT> Mobile code
+<DD> Because the server is written in Scheme 48, it is simple to use the
+     Scheme 48 module system to upload programs to the server for safe
+     execution within a protected, server-chosen environment. The server
+     comes with a simple example upload service to demonstrate this
+     capability.
+
+
+<DT> Clarity of implementation
+<DD> Because the server is written in a high-level language, it should make
+     for a clearer exposition of the HTTP protocol and the associated URL
+     and URI notations than one written in a low-level language such as C.
+     This also should help to make the server easy to modify and adapt to
+     different uses.
+</DL>
+
+<!---------------------------------------------------------------------------->
+<H3>Basic server structure</H3>
+
+The Web server is started by calling the <CODE>httpd</CODE> procedure,
+which takes one required and two optional arguments:
+<PRE>
+    (httpd <VAR>path-handler</VAR> [<VAR>port</VAR> <VAR>working-directory</VAR>])
+</PRE>
+
+The server accepts connections from the given port, which defaults to 80.
+The server runs with the working directory set to the given value,
+which defaults to
+<PRE>
+    /usr/local/etc/httpd
+</PRE>
+
+
+ <P>
+The server's basic loop is to wait on the port for a connection from an HTTP
+client. When it receives a connection, it reads in and parses the request into
+a special request data structure. Then the server forks a child process, who
+binds the current I/O ports to the connection socket, and then hands off to
+the top-level path handler (the first argument to <CODE>httpd</CODE>).
+The path-handler procedure is responsible for actually serving the request --
+it can be any arbitrary computation.
+Its output goes directly back to the HTTP client that sent the request.
+
+ <P>
+Before calling the path handler to service the request, the HTTP server
+installs an error handler that fields any uncaught error, sends an
+error reply to the client, and aborts the request transaction. Hence
+any error caused by a path-handler will be handled in a reasonable and
+robust fashion.
+
+ <P>
+The basic server loop, and the associated request data structure are the fixed
+architecture of the S.U. Web server; its flexibility lies in the notion of
+path handlers.
+
+
+<!---------------------------------------------------------------------------->
+<H3>Path handlers</H3>
+
+A path handler is a procedure taking two arguments:
+<PRE>
+    (path-handler <VAR>path</VAR> <VAR>req</VAR>)
+</PRE>
+
+
+The <VAR>req</VAR> argument is a request record giving all the details of the
+client's request; it has the following structure:
+<PRE>
+    (define-record request
+      method		; A string such as "GET", "PUT", etc.
+      uri		; The escaped URI string as read from request line.
+      url		; An http URL record (see url.scm).
+      version		; A (major . minor) integer pair.
+      headers		; An rfc822 header alist (see rfc822.scm).
+      socket)		; The socket connected to the client.
+</PRE>
+
+The <VAR>path</VAR> argument is the URL's path,
+parsed and split at slashes into a string list.
+For example, if the Web client dereferences URL
+<PRE>
+    http://clark.lcs.mit.edu:8001/h/shivers/code/web.tar.gz
+</PRE>
+then the server would pass the following path to the top-level handler:
+<PRE>
+    ("h" "shivers" "code" "web.tar.gz")
+</PRE>
+
+ <P>
+The path argument's pre-parsed representation as a string list makes it easy
+for the path handler to implement recursive operations dispatch on URL paths.
+
+ <P>
+Path handlers can do anything they like to respond to HTTP requests; they have
+the full range of Scheme to implement the desired functionality.  When
+handling HTTP requests that have an associated entity body (such as POST), the
+body should be read from the current input port. Path handlers should in all
+cases write their reply to the current output port. Path handlers should
+<EM>not</EM> perform I/O on the request record's socket.
+Path handlers are frequently called recursively, and doing I/O directly to the
+socket might bypass a filtering or other processing step interposed on the
+current I/O ports by some superior path handler.
+
+<!---------------------------------------------------------------------------->
+<H3>Basic path handlers</H3>
+
+Although the user can write any path-handler he likes, the S.U. server comes
+with a useful toolbox of basic path handlers that can be used and built upon:
+
+<DL>
+
+<DT>
+<CODE>(alist-path-dispatcher <VAR>ph-alist</VAR> <VAR>default-ph</VAR>) -> <VAR>path-handler</VAR>
+</CODE>
+<DD>
+    This procedure takes a string->path-handler alist, and a default
+    path handler, and returns a handler that dispatches on its path argument.
+    When the new path handler is applied to a path
+    <CODE>("foo" "bar" "baz")</CODE>,
+    it uses the first element of the path -- <CODE>"foo"</CODE> -- to
+    index into the alist.
+    If it finds an associated path handler in the alist, it
+    hands the request off to that handler, passing it the tail of the
+    path, <CODE>("bar" "baz")</CODE>.
+    On the other hand, if the path is empty, or the alist search does
+    not yield a hit, we hand off to the default path handler,
+    passing it the entire original path, <CODE>("foo" "bar" "baz")</CODE>.
+
+    <P>
+    This procedure is how you say: "If the first element of the URL's path
+    is `foo', do X; if it's `bar', do Y; otherwise, do Z." If one takes
+    an object-oriented view of the process, an alist path-handler does
+    method lookup on the requested operation, dispatching off to the
+    appropriate method defined for the URL.
+
+    <P>
+    The slash-delimited URI path structure implies an associated
+    tree of names. The path-handler system and the alist dispatcher
+    allow you to procedurally define the server's response to any arbitrary
+    subtree of the path space.
+
+    <P>
+    Example: <br>
+    A typical top-level path handler is
+
+<PRE>
+  (define ph
+    (alist-path-dispatcher
+	`(("h"       . ,(home-dir-handler "public_html"))
+	  ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))
+	  ("seval"   . ,seval-handler))
+	(rooted-file-handler "/usr/local/etc/httpd/htdocs")))
+</PRE>
+
+    This means:
+<UL>
+<LI> If the path looks like <CODE>("h" "shivers" "code" "web.tar.gz")</CODE>,
+     pass the path <CODE>("shivers" "code" "web.tar.gz")</CODE> to a
+     home-directory path handler.
+
+
+<LI> If the path looks like <CODE>("cgi-bin" "calendar")</CODE>,
+     pass <CODE>("calendar")</CODE> off to the CGI path handler.
+
+
+<LI> If the path looks like <CODE>("seval" ...)</CODE>,
+     the tail of the path is passed off to the code-uploading seval
+     path handler.
+
+<LI> Otherwise, the whole path is passed to a rooted file handler, who
+     will convert it into a filename, rooted at
+     <CODE>/usr/local/etc/httpd/htdocs</CODE>, and serve that file.
+</UL>
+
+
+<DT> <CODE>(home-dir-handler <VAR>subdir</VAR>) ->
+           <VAR>path-handler</CODE></VAR>
+<DD>
+    This procedure builds a path handler that does basic file serving
+    out of home directories. If the resulting path handler is passed
+    a path of <CODE>(<VAR>user</VAR> . <VAR>file-path</VAR>)</CODE>,
+    then it serves the file
+<PRE>
+    <VAR>user's-home-directory</VAR>/<VAR>subdir</VAR>/<VAR>file-path</VAR>
+</PRE>
+    The path handler only handles GET requests; the filename is not
+    allowed to contain <CODE>..</CODE> elements.
+
+
+<DT>
+<CODE>(tilde-home-dir-handler <VAR>subdir</VAR> <VAR>default-path-handler</VAR>)
+       -> <VAR>path-handler</VAR>
+</CODE>
+<DD>
+    This path handler examines the car of the path. If it is a string
+    beginning with a tilde, <em>e.g.</em>, "<CODE>~ziggy</CODE>",
+    then the string is taken
+    to mean a home directory, and the request is served similarly to a
+    <CODE>home-dir-handler</CODE> path handler.
+    Otherwise, the request is passed off
+    in its entirety to the default path handler.
+
+    <P>
+    This procedure is useful for implementing servers that provide the
+    semantics of the NCSA httpd server.
+
+
+<DT>
+<CODE>(cgi-handler <VAR>cgi-directory</VAR>) -> <VAR>path-handler</VAR>
+</CODE>
+<DD>
+    This procedure returns a path-handler that passes the request off to some
+    program using the CGI interface. The script name is taken from the
+    car of the path; it is checked for occurrences of <CODE>..</CODE>'s.
+    If the path is
+<PRE>
+    ("my-prog" "foo" "bar")
+</PRE>
+    then the program executed is
+<PRE>
+    <VAR>cgi-directory</VAR>/my-prog
+</PRE>
+    <P>
+    When the CGI path handler builds the process environment for the
+    CGI script, several elements
+    (<em>e.g.</em>, <CODE>$PATH</CODE> and <CODE>$SERVER_SOFTWARE</CODE>)
+    are request-invariant, and can be computed at server start-up time.
+    This can be done by calling
+<PRE>
+    (initialise-request-invariant-cgi-env)
+</PRE>
+    when the server starts up. This is <EM>not</EM> necessary,
+    but will make CGI requests a little faster.
+
+
+<DT>
+<CODE>(rooted-file-handler <VAR>root-dir</VAR>) -> <VAR>path-handler</VAR>
+</CODE>
+<DD>
+    Returns a path handler that serves files from a particular root
+    in the file system. Only the GET operation is provided. The path
+    argument passed to the handler is converted into a filename,
+    and appended to <VAR>root-dir</VAR>.
+    The file name is checked for <CODE>..</CODE> components,
+    and the transaction is aborted if it does. Otherwise, the file is
+    served to the client.
+
+<DT>
+<CODE>(null-path-handler <VAR>path</VAR> <VAR>req</VAR>)</CODE>
+<DD>
+    This path handler is useful as a default handler. It handles no requests,
+    always returning a "404 Not found" reply to the client.
+
+</DL>
+
+<!---------------------------------------------------------------------------->
+<H3>HTTP errors</H3>
+
+Authors of path-handlers need to be able to handle errors in a reasonably
+simple fashion. The S.U. Web server provides a set of error conditions that
+correspond to the error replies in the HTTP protocol. These errors can be
+raised with the <CODE>http-error</CODE> procedure.
+When the server runs a path handler,
+it runs it in the context of an error handler that catches these errors,
+sends an error reply to the client, and closes the transaction.
+
+<DL>
+
+<DT>
+<CODE>(http-error <VAR>reply-code</VAR> <VAR>req</VAR> [<VAR>extra</VAR> ...])</CODE>
+<DD>
+    This raises an http error condition. The reply code is one of the
+    numeric HTTP error reply codes, which are bound to the variables
+    <CODE>http-reply/ok</CODE>, <CODE>http-reply/not-found</CODE>,
+    <CODE>http-reply/bad-request</CODE>, and so
+    forth. The <VAR>req</VAR> argument is the request record that caused
+    the error.
+    Any following <VAR>extra</VAR> args are passed along for
+    informational purposes.
+    Different HTTP errors take different types of extra arguments.
+    For example, the "301 moved permanently" and "302 moved temporarily"
+    replies use the first two <VAR>extra</VAR> values as the
+    <CODE>URI:</CODE> and <CODE>Location:</CODE>
+    fields in the reply header, respectively. See the clauses of the
+    <CODE>send-http-error-reply</CODE> procedure for details.
+
+
+<DT>
+<CODE>(send-http-error-reply <VAR>reply-code</VAR> <VAR>request</VAR>
+                             [<VAR>extra</VAR> ...])
+</CODE>
+<DD>
+    This procedure writes an error reply out to the current output
+    port. If an error occurs during this process, it is caught, and
+    the procedure silently returns. The http server's standard error
+    handler passes all http errors raised during path-handler execution
+    to this procedure to generate the error reply before aborting the
+    request transaction.
+</DL>
+
+<!---------------------------------------------------------------------------->
+<H3>Simple directory generation</H3>
+
+Most path-handlers that serve files to clients eventually call an internal
+procedure named <CODE>file-serve</CODE>,
+which implements a simple directory-generation service using the
+following rules:
+<UL>
+<LI> If the filename has the <EM>form</EM> of a directory
+     (<EM>i.e.</EM>, it ends with a slash),
+     then <CODE>file-serve</CODE> actually looks for a
+     file named "<CODE>index.html</CODE>" in that directory.
+
+<LI> If the filename names a directory, but is not in directory form
+      (<EM>i.e.</EM>, it doesn't end in a slash,
+      as in "<CODE>/usr/include</CODE>" or "<CODE>/usr/raj</CODE>"),
+      then <CODE>file-serve</CODE> sends back a "301 moved permanently"
+      message,
+      redirecting the client to a slash-terminated version of the original
+      URL. For example, the URL
+<PRE>
+    http://clark.lcs.mit.edu/~shivers
+</PRE>
+      would be redirected to
+<PRE>
+    http://clark.lcs.mit.edu/~shivers/
+</PRE>
+
+<LI> If the filename names a regular file, it is served to the client.
+</UL>
+
+
+<!---------------------------------------------------------------------------->
+<H3>Support procs</H3>
+
+The source files contain a host of support procedures which will be of utility
+to anyone writing a custom path-handler. Read the files first.
+
+
+<!---------------------------------------------------------------------------->
+<H3>Losing</H3>
+
+Be aware of two Unix problems, which may require workarounds:
+<OL>
+
+<LI>
+   NeXTSTEP's Posix implementation of the <CODE>getpwnam()</CODE> routine
+   will silently tell you that every user has uid 0. This means
+   that if your server, running as root, does a
+<PRE>
+    (set-uid (user->uid "nobody"))
+</PRE>
+   it will essentially do a
+<PRE>
+    (set-uid 0)
+</PRE>
+   and you will thus still be running as root.
+
+   <P>
+   The fix is to manually find out who user nobody is (he's -2 on my
+   system), and to hard-wire this into the server:
+<PRE>
+    (set-uid -2)
+</PRE>
+   This problem is NeXTSTEP specific. If you are using not using NeXTSTEP,
+   no problem.
+
+
+<LI>
+   On NeXTSTEP, the ip-address->host-name translation routine
+   (in C, <CODE>gethostbyaddr()</CODE>; in scsh,
+   <CODE>(host-info addr)</CODE>) does not
+   use the DNS system; it goes through NeXT's propietary Netinfo
+   system, and may not return a fully-qualified domain name. For
+   example, on my system, I get "amelia-earhart", when I want
+   "amelia-earhart.lcs.mit.edu". Since the server uses this name
+   to construct redirection URL's to be sent back to the Web client,
+   they need to be FQDN's.
+
+   <P>
+   This problem may occur on other OS's;
+   I cannot determine if <CODE>gethostbyaddr()</CODE>
+   is required to return a FQDN or not. (I would appreciate hearing the
+   answer if you know; my local Internet guru's couldn't tell me.)
+
+   <P>
+   If your system doesn't give you a complete Internet address when
+   you say
+<PRE>
+    (host-info:name (host-info (system-name)))
+</PRE>
+   then you have this problem.
+
+   <P>
+   The server has a workaround. There is a procedure exported from
+   the httpd-core package:
+<PRE>
+    (set-my-fqdn name)
+</PRE>
+   Call this to crow-bar the server's idea of its own Internet host name
+   before running the server, and all will be well.
+</OL>
+
+</BODY>
+</HTML>

doc/latex/.gitignore

@@ -0,0 +1,7 @@
+*.aux
+*.toc
+*.dvi
+*.ps
+*.pdf
+*.log
+

doc/latex/cgi-script.tex

@@ -0,0 +1,21 @@
+\chapter{CGI scripts}\label{cha:cgi-scripts}
+%
+\begin{description}
+\item[Used files:] cgi-script.scm
+\item[Name of the package:] cgi-script
+\end{description}
+%
+\section{Procedures}
+
+\begin{defundesc}{cgi-form-query}{}{data-alist}
+ CGI scripts receive their parameters in various ways, depending on
+ how they were called (e.g. by ``GET'' method). This procedure
+ translates the delivered form data into an alist of decoded strings,
+ using the environment variables set by the server
+ (\ex{REQUEST\_METHOD}, \ex{QUERY\_STRING} (``GET'' script),
+ \ex{CONTENT\_LENGTH} (``POST'' script)). So a query string like
+ \codex{button=on\&\ob{}reply=Oh,\ob{}\%20yes} becomes alist
+ \codex{(("button" . "on") ("reply" . "Oh, yes"))} This only works for
+ GET and POST methods.
+\end{defundesc}
+

doc/latex/cgi.tex

@@ -0,0 +1,8 @@
+\section{CGI server}
+%
+\begin{description}
+\item[Used files:] cgi-server.scm
+\item[Name of the package:] cgi-server
+\end{description}
+%
+Not implemented yet.

doc/latex/decls.tex

@@ -0,0 +1,281 @@
+\makeatletter   
+\def\ie{\mbox{\emph{i.e.}}}        % \mbox keeps the last period from
+\def\Ie{\mbox{\emph{I.e.}}}        % looking like an end-of-sentence.
+\def\eg{\mbox{\emph{e.g.}}}
+\def\Eg{\mbox{\emph{E.g.}}}
+\def\etc{{\em etc.}}
+
+\def\Lisp{\textsc{Lisp}}
+\def\CommonLisp{\textsc{Common Lisp}}
+\def\Ascii{\textsc{Ascii}}
+\def\Ansi{\textsc{Ansi}}
+\def\Unix{{Unix}} % Not smallcaps, according to Bart.
+\def\Scheme{{Scheme}}
+\def\scm{{Scheme 48}}
+\def\RnRS{R5RS\ }
+\def\Posix{\textsc{Posix}}
+
+\def\sharpf{\normalfont\texttt{\#f}}
+\def\sharpt{\normalfont\texttt{\#t}}
+\newcommand{\synteq}{\textnormal{::=}}
+
+\def\maketildeother{\catcode`\~=12}
+\def\maketildeactive{\catcode`\~=13}
+\def\~{\char`\~}
+
+\newcommand{\evalsto}{\ensuremath{\Rightarrow}}
+
+% One-line code examples
+%\newcommand{\codex}[1]%                One line, centred. Tight spacing.
+%  {$$\abovedisplayskip=.75ex plus 1ex minus .5ex%
+%     \belowdisplayskip=\abovedisplayskip%
+%     \abovedisplayshortskip=0ex plus .5ex%
+%     \belowdisplayshortskip=\abovedisplayshortskip%
+%     \hbox{\ttt #1}$$}
+%\newcommand{\codex}[1]{\begin{tightinset}\ex{#1}\end{tightinset}\ignorespaces}
+\newcommand{\codex}[1]{\begin{leftinset}\ex{#1}\end{leftinset}\ignorespaces}
+
+\def\widecode{\codeaux{\leftmargin=0pt\topsep=0pt}}
+\def\endwidecode{\endcodeaux}
+
+% For multiletter vars in math mode:
+\newcommand{\var}[1]{\mbox{\frenchspacing\it{#1}}}
+\newcommand{\vari}[2]{\ensuremath{\mbox{\it{#1}}_{#2}}}
+\newcommand{\ovar}[1]{\mbox{\textnormal{[}\frenchspacing\it{#1}\textnormal{]}}}
+
+%% What you frequently want when you say \tt:
+\def\ttchars{\catcode``=13\@noligs\frenchspacing}
+\def\ttt{\normalfont\ttfamily\ttchars}
+
+% Works in math mode; all special chars remain special; cheaper than \cd.
+% Will not be correct size in super and subscripts, though.
+\newcommand{\ex}[1]{{\normalfont\texttt{\ttchars #1}}}
+
+\newenvironment{inset}
+ {\bgroup\parskip=1ex plus 1ex\begin{list}{}%
+        {\topsep=0pt\rightmargin\leftmargin}%
+        \item[]}%
+ {\end{list}\leavevmode\egroup\global\@ignoretrue}
+
+\newenvironment{leftinset}
+ {\bgroup\parskip=1ex plus 1ex\begin{list}{}%
+        {\topsep=0pt}%
+        \item[]}%
+ {\end{list}\leavevmode\egroup\global\@ignoretrue}
+
+\newenvironment{tightinset}
+ {\bgroup\parskip=0pt\begin{list}{}%
+        {\topsep=0pt\rightmargin\leftmargin}%
+        \item[]}%
+ {\end{list}\leavevmode\egroup\global\@ignoretrue}
+
+\newenvironment{tightleftinset}
+ {\bgroup\parskip=0pt\begin{list}{}%
+        {\topsep=0pt}%
+        \item[]}%
+ {\end{list}\leavevmode\egroup\global\@ignoretrue}
+
+\long\def\remark#1{\bgroup\small\begin{quote}\textsl{Remark: } #1\end{quote}\egroup}
+\newenvironment{remarkenv}{\bgroup\small\begin{quote}\textsl{Remark: }}%
+                          {\end{quote}\egroup}
+\newcommand{\oops}[1]{\bgroup\small\begin{quote}\textsl{Oops: } #1\end{quote}\egroup}
+
+\newcommand{\note}[1]{\{Note #1\}}
+
+% For use in code. The \llap magicness makes the lambda exactly as wide as
+% the other chars in \tt; the \hskip shifts it right a bit so it doesn't
+% crowd the left paren -- which is necessary if \tt is cmtt.
+% Note that (\l{x y} (+ x y)) uses the same number of columns in TeX form
+% as it produces when typeset. This makes it easy to line up the columns
+% in your input. \l is bound to some useless command in LaTeX, so we have to
+% define it w/renewcommand.
+\let\oldl\l %Save the old \l on \oldl
+\renewcommand{\l}[1]{\ \llap{$\lambda$\hskip-.05em}\ (#1)}
+
+% This one is for the rare (lambda x ...) case -- it doesn't have the
+% column-invariant property. Oh, well.
+\newcommand{\lx}[1]{\ \llap{$\lambda$\hskip-.05em}\ {#1}}
+
+% For subcaptions
+\newcommand{\subcaption}[1]
+{\unskip\vspace{-2mm}\begin{center}\unskip\em#1\end{center}}
+
+%%% T release notes stuff
+\newlength{\notewidth}
+\setlength{\notewidth}{\textwidth}
+\addtolength{\notewidth}{-1.25in}
+
+%\newcommand{\remark} [1]
+%  {\par\vspace{\parskip}
+%   \parbox[t]{.75in}{\sc Remark:}
+%   \parbox[t]{\notewidth}{\em #1}
+%   \vspace{\parskip}
+%   }
+
+\newenvironment{optiontable}%
+  {\begin{tightinset}\renewcommand{\arraystretch}{1.5}%
+   \begin{tabular}{@{}>{\ttt}ll@{}}}%
+  {\end{tabular}\end{tightinset}}%
+
+\newenvironment{desctable}[1]%
+  {\begin{inset}\renewcommand{\arraystretch}{1.5}%
+   \begin{tabular}{lp{#1}}}%
+  {\end{tabular}\end{inset}}
+
+\def\*{{\ttt *}}
+
+% Names of things
+
+\newcommand{\keyword} [1]{\index{#1}{\normalfont\textsf{#1}}}
+
+\newcommand{\evalto}{$\Longrightarrow$\ }
+\renewcommand{\star}{$^*$\/}
+\newcommand{\+}{$^+$}
+
+% Semantic domains,  used to indicate the type of a value
+
+\newcommand{\sem}{\normalfont\itshape}   %semantic font
+\newcommand{\semvar}[1]{\textit{#1}}     %semantic font
+\newcommand{\synvar}[1]{\textrm{\textit{$<$#1$>$}}}  %syntactic font
+\newcommand{\type}{\sem}
+\newcommand{\zeroormore}[1]{{\sem #1$_1$ \ldots  #1$_n$}}
+\newcommand{\oneormore}[1]{{\sem #1$_1$ #1$_2$ \ldots #1$_n$}}
+
+\newcommand{\proc}        {{\sem procedure}}
+\newcommand{\boolean}     {{\sem boolean}}
+\newcommand{\true}        {{\sem true}}
+\newcommand{\false}       {{\sem false}}
+
+\newcommand{\num}         {{\sem number}}
+\newcommand{\fixnum}      {{\sem fixnum}}
+\newcommand{\integer}     {{\sem integer}}
+\newcommand{\real}        {{\sem real}}
+
+\newcommand{\character}   {{\sem character}}
+\newcommand{\str}         {{\sem string}}
+\newcommand{\sym}         {{\sem symbol}}
+
+\newcommand{\location}    {{\sem location}}
+\newcommand{\object}      {{\sem object}}
+
+\newcommand{\error}       {{\sem error}}
+\newcommand{\syntaxerror} {{\sem syntax error}}
+\newcommand{\readerror}   {{\sem read error}}
+\newcommand{\undefined}   {{\sem undefined}}
+\newcommand{\noreturn}    {{\sem no return value}}
+
+\newcommand{\port}        {{\sem port}}
+
+% semantic variables
+
+\newcommand{\identifier}  {{\sem identifier}}
+\newcommand{\identifiers} {\zeroormore{\<ident>}}
+\newcommand{\expr}        {{\sem expression}}
+\newcommand{\body}        {{\sem body}}
+\newcommand{\valueofbody} {{\sem value~of~body}}
+\newcommand{\emptylist}   {{\sem empty~list}}
+\newcommand{\car}         {\keyword{car}}
+\newcommand{\cdr}         {\keyword{cdr}}
+\newcommand{\TMPDIR}{\texttt{\$TMPDIR}}
+
+% generally useful things
+
+% For line-breaking \tt stuff.
+\renewcommand{\=}{\discretionary{-}{}{-}}
+\newcommand{\ob}{\discretionary{}{}{}} % Optional break.
+
+\newcommand{\indx}[1]{#1 \index{ #1 }}
+%\newcommand{\gloss}[1]{#1 \glossary{ #1 }}
+
+% This lossage produces #2 if #1 is zero length, otw #3.
+% We use it to conditionally add a space between the procedure and
+% the args in procedure prototypes, but only if there are any args--
+% we want to produce "(read)", not "(read )".
+\newlength{\voidlen}
+\newcommand{\testvoid}[3]{\settowidth\voidlen{#1}\ifdim\voidlen>0in{#3}\else{#2}\fi}
+
+
+% Typeset a definition prototype line, e.g.:
+% (cons <arg1> <arg2>) -> pair                    procedure
+%
+% Five args are: proc-name args ret-value(s) type index-entry
+\newcommand{\dfnix}[5]
+  {\hbox to \linewidth{\ttchars%
+     {\ttt(#1\testvoid{#2}{}{\ }{\sem{#2}}\testvoid{#2}{}{\/})\hskip 1em minus
+0.5em$\longrightarrow$\hskip 1em minus 0.5em{\sem{#3}}\hfill\quad\textnormal{#4}}}\index{#5}}
+
+\newcommand{\dfnx}[4] {\dfnix{#1}{#2}{#3}{#4}{#1@\texttt{#1}}}
+
+\newcommand{\dfn}  {\par\medskip\dfnx}  % Takes 4 args, actually.
+\newcommand{\dfni} {\par\medskip\dfnix} % Takes 5 args, actually.
+
+\newcommand{\defvar}     {\par\medskip\defvarx} % Takes 2 args, actually.
+\newcommand{\defvarx}[2]%
+  {\index{#1}
+   \hbox to \linewidth{\ttchars{{\ttt{#1}} \hfill #2}}}%
+
+% Typeset the protocol line, then do the following descriptive text indented.
+% If you want to group two procs together, do the first one with a \dfn, 
+% then the second one, and the documentation, with a \defndescx.
+
+% This one doesn't put whitespace above. Use it immediately after a \dfn
+% to group two prototype lines together.
+\newenvironment{dfndescx}[4]%           
+    {\dfnx{#1}{#2}{#3}{#4}\begin{desc}}{\end{desc}}
+
+\newenvironment{dfndesc}[4]             % This one puts whitespace above.
+  {\par\medskip\begin{dfndescx}{#1}{#2}{#3}{#4}}
+  {\end{dfndescx}}    
+
+\newenvironment{desc}%
+    {\nopagebreak[2]%
+     \smallskip
+     \bgroup\begin{list}{}{\topsep=0pt\parskip=0pt}\item[]}
+    {\end{list}\leavevmode\egroup\global\@ignoretrue}
+
+\newcommand{\defun}   [3] {\dfn{#1}{#2}{#3}{procedure}}  % preskip
+\newcommand{\defunx}[3]{\dfnx{#1}{#2}{#3}{procedure}} % no skip
+
+\newenvironment{defundescx}[3]%
+    {\begin{dfndescx}{#1}{#2}{#3}{procedure}}
+    {\end{dfndescx}}
+
+\newenvironment{defundesc}[3]%
+    {\begin{dfndesc}{#1}{#2}{#3}{procedure}}
+    {\end{dfndesc}}
+
+
+\newenvironment{column}{\begin{tabular}[t]{@{}l@{}}}{\end{tabular}}
+
+\newenvironment{exampletable}%
+    {\begin{leftinset}%
+       \newcommand{\header}[1]{\multicolumn{2}{@{}l@{}}{##1}\\}%
+       \newcommand{\splitline}[2]%
+                {\multicolumn{2}{@{}l@{}}{##1}\\\multicolumn{2}{@{}l@{}}{\qquad\evalto\quad{##2}}}
+       \begin{tabular}{@{}l@{\quad\evalto\quad}l@{}}}%
+    {\end{tabular}\end{leftinset}}
+
+% Put on blank lines in a code env to allow a pagebreak.
+\newcommand{\cb}{\pagebreak[0]}
+
+\newenvironment{boxedcode}
+        {\begin{inset}\tabular{|l|}\hline}
+        {\\ \hline \end{tabular}\end{inset}}
+
+% A ragged-right decl that doesn't redefine \\ -- for use in tables.
+\newcommand{\raggedrightparbox}{\let\temp=\\\raggedright\let\\=\temp}
+
+\newenvironment{boxedfigure}[1]%
+        {\begin{figure}[#1]\begin{boxedminipage}{\linewidth}\vskip 1.5ex}
+        {\end{boxedminipage}\end{figure}}
+
+%FIXME-command: types out the desired FIXME
+\newcommand{\FIXME}[1]%
+{\typeout{**********************************}%
+\typeout{FIXME: #1}%
+\typeout{**********************************}}
+
+
+\makeatother
+
+\dontuseimgforhtmlmath

doc/latex/ftp.tex

@@ -0,0 +1,281 @@
+\chapter{FTP client}\label{cha:ftp}
+\begin{description}
+\item[Used files:] ftp.scm, ftp-obsolete.scm
+\item[Name of the package:] ftp, ftp-obsolete
+\end{description}
+
+\section{What users want to know}
+This module lets you transfer files between networked machines from
+the Scheme Shell, using the File Transfer Protocol as described in
+RFC~959. The protocol specifies the behaviour of a server machine,
+which runs an ftp daemon (not implemented by this module), and of
+clients (that's us) which request services from the server.
+
+Some of the procedures in this module extract useful information from
+the server's reply, such as the size of a file, or the name of the
+directory we have moved to. These procedures return either the
+extracted information, or \sharpf{} to indicate failure. Other
+procedures return a ``status'', which is either the server's reply as
+a string, or \sharpf{} to signify failure.
+
+The server's response is always checked. If the server's response
+doesn't match the expected code from the server, a catchable
+\ex{ftp-error} is raised.  
+
+\FIXME{The source says you can look at pop3.scm to find out how to
+catch the ftp-error raised by some procedures this. We have not had
+a look there, yet.}
+
+\subsubsection*{Entry points }
+
+\defun{ftp-connect} {host \ovar{logfile}} {connection}
+\begin{desc}
+  Open a command connection with the remote machine \semvar{host}.
+  Optionally start logging the conversation with the server to
+  \semvar{logfile}, which will be appended to if it already exists,
+  and created otherwise. Beware, the \semvar{logfile} contains
+  passwords in clear text (it is created with permissions
+  \ex{og-rxw})!
+\end{desc}
+
+\defun{ftp-login} {connection \ovar{login \ovar{passwd}}} {status}
+\begin{desc}
+  Log in to the remote host. If a \semvar{login} and \semvar{password}
+  are not provided, they are first searched for in the user's
+  \~/.netrc file, or default to user ``anonymous'' and password
+  ``user@host''
+\end{desc}
+
+\defun{ftp-type} {connection type} {status}
+\begin{desc}
+  Change the transfer mode for future data connections. This may be
+  either \ex{'ascii }or \ex{'text}, respectively, for transfering text
+  files, or \ex{'binary} for transfering binary files. If
+  \semvar{type} is a string it is sent verbatim to the server.
+\end{desc}
+
+\defun{ftp-rename} {connection oldname newname} {status}
+\begin{desc}
+  Change the name of \semvar{oldname} on the remote host to
+  \semvar{newname} (assuming sufficient permissions). \semvar{oldname}
+  and \semvar{newname} are strings; if prefixed with "/" they are
+  taken relative to the server's root, and otherwise they are relative
+  to the current directory. Note that in the case of anonymous ftp
+  (user ``anonymous'' or ``ftp''), the server root is different from
+  the root of the servers's filesystem.
+\end{desc}
+
+\defun{ftp-delete} {connection file} {status}
+\begin{desc}
+  Delete \semvar{file} from the remote host (assuming the user has
+  appropriate permissions).
+\end{desc}
+
+\defun{ftp-cd} {connection dir} {status}
+\begin{desc}
+  Change the current directory on the server.
+\end{desc}
+
+\defun{ftp-cdup} {connection} {status}
+\begin{desc}
+  Move to the parent directory on the server.
+\end{desc}
+
+\defun{ftp-pwd} {connection} {string}
+\begin{desc}
+  Return the current directory on the remote host, as a string.
+\end{desc}
+
+\defun{ftp-ls} {connection} {status}
+\begin{desc}
+  Provide a listing of the current directory's contents, in short
+  format, \ie as a list of filenames.
+\end{desc}
+
+\defun{ftp-dir} {connection} {status}
+\begin{desc}
+  Provide a listing of the current directory's contents, in long
+  format. Most servers (\Unix, MS Windows, MacOS) use a standard
+  format with one file per line, with the file size and other
+  information, but other servers (VMS, \ldots) use their own format.
+\end{desc}
+
+\defun{ftp-get} {connection remote-file \ovar{local-file}} {status $|$ string}
+\begin{desc}
+  Download \semvar{remote-file} from the FTP server. If
+  \semvar{local-file} is a string, save the data to
+  \semvar{local-file} on the local host; otherwise save to a local
+  file named \semvar{remote-file}.  \semvar{remote-file} and
+  \semvar{local-file} may be absolute file names (with a leading `/'),
+  or relative to the current directory. If \semvar{local-file} is
+  \sharpt, output data to \ex{(current-output-port)}, and if it is
+  \sharpf{} return the data as a string.
+\end{desc}
+
+\defun{ftp-put} {connection local-file \ovar{remote-file}} {status}
+\begin{desc}
+  Upload \semvar{local-file} to the FTP server. If
+  \semvar{remote-file} is specified, then save the data to
+  \semvar{remote-file} on the remote host; otherwise save to a remote
+  file named \semvar{local-file}.  \semvar{local-file} and
+  \semvar{remote-file} may be absolute file names (with a leading
+  `/'), or relative to the current directory.
+\end{desc}
+
+\defun{ftp-append}{connection local-file \ovar{remote-file}}{status}
+\begin{desc}
+  Does the same as \ex{ftp-get}, but appends the data to the remote
+  file, if it exists.
+\end{desc}
+
+\defun{ftp-rmdir} {connection dir} {status}
+\begin{desc}
+  Remove the directory \semvar{dir} from the remote host (assuming
+  sufficient permissions).
+\end{desc}
+
+\defun{ftp-mkdir} {connection dir} {status}
+\begin{desc}
+  Create a new directory named \semvar{dir} on the remote host
+  (assuming sufficient permissions).
+\end{desc}
+
+\defun{ftp-modification-time} {connection file} {date}
+\begin{desc}
+  Request the time of the last modification of \semvar{file} on the
+  remote host, and on success return a Scsh date record. This command
+  is not part of RFC~959 and is not implemented by all servers, but is
+  useful for mirroring.
+\end{desc}
+
+\defun{ftp-size} {connection file} {integer}
+\begin{desc}
+  Return the size of \semvar{file} in bytes.
+\end{desc}
+
+\defun{ftp-abort} {connection} {status}
+\begin{desc}
+  Abort the current data transfer. Not particularly useful with this
+  im\-ple\-men\-ta\-tion since the data transfer commands only return
+  once the transfer is complete.
+\end{desc}
+
+\defun{ftp-quit} {connection} {status}
+\begin{desc}
+  Close the connection to the remote host. The \semvar{connection}
+  object is useless after a quit command.
+\end{desc}
+
+\defun{ftp-quot}{connection command}{status}
+\begin{desc}
+  Send a \semvar{command} verbatim to the remote server and wait for a
+  response.
+\end{desc}
+
+\defun{ftp-error?}{thing}{boolean}
+\begin{desc}
+  Returns \sharpt, if \semvar{thing} is a \ex{ftp-error} object,
+otherwise \sharpf.
+\end{desc}
+
+\subsubsection*{Unimplemented}
+
+The following rfc959 commands are not implemented:
+
+\begin{tabular}{ll}
+\ex{ACCT} & account; this is ignored by most servers) \\
+\ex{SMNT} & structure mount, for mounting another filesystem \\
+\ex{REIN} & reinitialize connection \\
+\ex{LOGOUT} & quit without interrupting ongoing transfers \\
+\ex{STRU} & file structure \\
+\ex{ALLO} & allocate space on server \\
+\end{tabular}
+
+\section{What programmers want to know}
+
+\section{Overview}
+Communication is initiated by the client. The server responds to each
+request with a three digit status code and an explanatory message, and
+occasionally with data (which is sent via a separate, one-off
+channel). The client starts by opening a command connection to a well
+known port on the server machine. Messages send to the server are of
+the form
+  \codex{CMD [ <space> arg ] <CR> <LF>}
+Replies from the server are of the form
+  \codex{xyz <space> Informative message <CR> <LF>}
+where xyz is a three digit code which indicates whether the operation
+succeeded or not, whether the server is waiting for more data, etc.
+The server may also send multiline messages of the form
+
+\begin{alltt}
+xyz- <space> Start of multiline message <CR> <LF>
+[ <space>+ More information ]* <CR> <LF>
+xyz <space> End of multiline message <CR> <LF>%
+\end{alltt}
+
+For further informations have a look at the source file.
+
+This module has no support for sites behind a firewall. It shouldn't
+be very tricky; it only requires using passive mode. Might want to add
+something like the \ex{/usr/bin/ftp} command \ex{restrict}, which
+implements data port range restrictions.
+
+\subsubsection*{Obsolete procedures}
+
+Names in further versions of \ex{ftp} contained a colon (`\ex{:}')
+after the prefix `\ex{ftp-}'. This is now changed to a hyphen
+('\ex{-}'), accordingly to SUnet's philosophy. If you need the old
+names, use the \ex{ftp\=obsolete}-package that maps the old names to
+the new ones.
+
+
+\subsubsection*{Portablitity}
+
+Items of the following list are necessary in order to use this module:
+\begin{itemize}
+\item The netrc.scm module for parsing ~/.netrc files.
+\item Scsh socket code
+\item Scsh records
+\item Receive for multiple values
+\item \scm{} signals/handlers
+\end{itemize}
+
+
+\subsubsection*{Related work}
+
+\begin{itemize}
+\item RFC~959 describes the FTP protocol; see \newline
+  \ex{http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html}
+\item \ex{/anonymous@sunsite.unc.edu:/pub/Linux/libs/ftplib.tar.gz} is
+  a library similar to this one, written in C, by Thomas Pfau
+\item \ex{FTP.pm} is a Perl module with similar functionality
+  (available from \ex{http://www.perl.com/CPAN})
+\item Emacs gets transparent remote file access from \ex{ange-ftp.el}
+  by Ange Norman. However, it cheats by using \ex{/usr/bin/ftp}.
+\item Siod (a small-footprint Scheme implementation by George Carette)
+  comes with a file \ex{ftp.scm }with a small subset of these
+  functions defined.
+\end{itemize}
+
+\subsubsection*{TODO}
+\begin{itemize}
+\item Handle passive mode and firewalls.
+\item Unix-specific commands such as \ex{SITE UMASK}, \ex{SITE CHMOD},
+  \ex{SITE IDLE}, \ex{SITE HELP}.
+\item Object-based interface? (like SICP message passing).
+\item Improved error handling.
+\item A lot of the calls to format could be replaced by calls to
+  string-join. Maybe format is easier to read?
+\item The \ex{ftp-rename} command should have an optional argument
+  \ex{:rename} which defaults to \sharpf, which would make us upload
+  to a temporary name and rename at the end of the upload. This
+  atomicity is important for ftp or http servers which are serving a
+  load, and to avoid problems with "no space on device".
+\item Automatic relogin a la \ex{ang-ftp}.
+\end{itemize}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: man.tex
+%%% End: 
+

doc/latex/ftpd.tex

@@ -0,0 +1,203 @@
+\chapter{FTP server}\label{cha:ftpd}
+
+\begin{description}
+\item[Used files:] ftpd.scm
+\item[Name of the package:] ftpd
+\end{description}
+
+\section{What users want to know}
+
+\section{Entry points}
+
+\defun  {ftpd} {anonymous-home \ovar{port \ovar{logfile \ovar{dns-lookup?}}}} {\noreturn}
+\begin{defundescx}{ftp-inetd} {anonymous-home} {\noreturn} 
+  \ex{ftpd} starts the server, using \semvar{anonymous-home} as the
+  root directory of the server. Usage of relative paths is not
+  encouraged.  \semvar{port} specifies the port the server is
+  listening for connections. It defaults to 21. \ex{ftpd} makes a log
+  entry for each file sent or retrieved. These logs are written to
+  \semvar{logfile}, if given. If \semvar{dns-lookup?} is \sharpt, the
+  logfile will contain the host names instead of their IP
+  addresses. If \semvar{dns-lookup?} is not specified or \sharpf, the
+  IP addresses are stored.
+
+  The log format of \ex{ftpd} is the same as the one of
+  \ex{wuftpd}. The fields are seperated by spaces and contain
+  following informations:
+\codex{Fri Apr 19 17:08:14 2002 4 134.2.2.171 56881 /files.lst b \_ i a nop@ssword ftp 0 *}
+  \begin{enumerate} 
+\item Current date and time. This field contains
+  spaces and is 24 characters long.
+\item Transfer time in seconds.
+\item Remote host IP (wuftpd puts the name here).
+\item File size in bytes
+\item Name of file (spaces are converted to underscores)
+\item Transfer type: \underline{a}scii or \underline{b}inary (image type).
+\item Special action flags. As \ex{ftpd} does not support any special
+action, we are always `\ex{\_}' here.
+\item File was sent to user (\underline{o}utgoing) or received from user
+(\underline{i}ncoming) 
+\item \underline{A}nonymous access
+\item Anonymous ftp password. We do not use anyone.
+\item Service name - always \ex{ftp}.
+\item Authentication mode (always none = `\ex{0}').
+\item Authenticated user ID (always not available = `\ex{*}')
+\end{enumerate}
+
+  As the procedure does not return, you have to do a \ex{fork} in
+  order to have a ``real'' daemon: \codex{(fork (lambda () (ftpd
+  "/data/ftp" 8080)))} \ex{ftpd-inetd} is the version to be used with
+  a daemon like \ex{inetd}. If the server is started this way, it
+  handles the connection through the current standard output and input
+  ports.
+\end{defundescx}
+
+\subsubsection*{Examples}
+
+To start the server with the current home directory as root directory
+and listening on port 8080, use
+\codex{(ftpd (cwd) 8080)}
+
+This is how the ftp server at the computing faculty of the university
+of Tuebingen\footnote{\texttt{archive.informatik.uni-tuebingen.de}} is
+started:
+\begin{alltt}
+#!/bin/sh /scsh-0.6-alpha/bin/scsh <<EOF
+,batch on
+,config ,load modules.scm
+,open ftpd
+,open threads
+(define (archive-ftpd args)
+  (with-syslog-destination
+   #f
+   #f
+   (syslog-facility local0)
+   #f
+   (lambda ()
+     (ftpd "/data/archive/"))))
+(dump-scsh-program archive-ftpd "archive-ftpd.image")
+;; (dump-scsh "archive-ftpd.image")
+EOF
+\end{alltt}
+
+Perhaps you have noticed the \ex{with-syslog-destination} command.
+\ex{ftpd} generates syslog-messages that can be controlled via this
+command. The following section gives you an overview of what is logged
+at which level. See \ex{man 3 syslog} or the
+\ex{with-syslog-destination} command in the scsh-manual for further
+details.
+
+\subsubsection*{Syslog messages}
+
+\ex{ftpd} outputs a lot of syslog-messages. A syslog-message may look like
+this:
+\codex{Jul 24 18:34:52 axl ftpd: (thread 21) anonymous user login (230)}
+
+The log gives you following informations (including those delivered by
+the syslog-daemon):
+
+\begin{enumerate}
+\item The date and time the log was made (here: Jul 24 18:34:52)
+\item The machine the log was made on (here: axl)
+\item The program, that output the log (ftpd)
+\item The thread the message concerns (here thread 21)
+  
+  Each connection is linked with a thread, that handles the commands
+  of this connection. When the thread is created, there is a entry in
+  the log file containing the remote address and the thread number, so
+  in future logs the thread number labels the connection. As at any
+  given time the thread number is unique, this is a bijection. (Note
+  that the thread numbers are not unique over a period of time).
+\item The log message (here: notification about an anonymous user login)
+\item The reply code returned by ftpd, if any (here: 230)
+\end{enumerate}
+
+\subsubsection*{The Syslog-levels used\footnote{For further details
+  on syslog levels see \ex{man 3 syslog}}}
+
+Following events are logged as
+\begin{description}
+
+\item[\ex{NOTICE} level:]
+\begin{itemize}
+\item Messages concerning \emph{connections} (establishing connection,
+  connection refused, closing connection due to timeout, etc.)
+\item The execution of the \ex{STOR} command. Its success (\ie
+  somebody is putting something on your server via ftp, also known as
+  \ex{PUT}) is also logged at notice-level. In fact, the log is made
+  before the storing is started actually.
+\item Internal errors
+\item Unix errors
+\item Reaching of actually unreachable case branches
+\end{itemize}
+
+\item[\ex{INFO} level:] Messages concerning all \emph{other commands},
+  including the \ex{RETR} command.
+  
+\item[\ex{DEBUG} level:] All other messages, including debug messages.
+  If you want to debug ftpd, put all the messages in one single file,
+  since the debug-messages may refer to messages of other levels.
+\end{description}
+
+Success (as long as interesting) and failure of commands are logged at
+info-level, except the success of the STOR-command, that is logged at
+notice-level (as mentioned above).
+\subsubsection*{Supported commands}
+
+For those of you who are intrested, the table \ref{ftpd-commands}
+shows the list of supported commands by \ex{ftpd} according to
+RFC~959:
+
+\FIXME{Can there be a pagebreak in a table?}
+
+
+\begin{table}
+\label{ftpd-commands}
+\begin{center}
+\begin{tabular}{|lp{10cm}|}
+\hline
+\ex{ABOR} & abort connection \\
+\ex{CDUP} & move to parent directory \\
+\ex{CWD} & move to specified directory (relative paths may be used) \\
+\ex{DELE} & delete file \\
+\ex{LIST} & list files in current directory (long format) \\
+\ex{MDTM} & deliver modification time of a regular file \\
+\ex{MKD}  & make directory \\
+\ex{MODE} & change mode (only stream mode (S) is supported) \\
+\ex{NLST} & list files in current directory (short format) \\
+\ex{NOOP} & do nothing \\
+\ex{PASS} & read in passphrase (\ex{ftpd} currently does not support
+non-anonymous logins) \\
+\ex{PASV} & change to passive mode \\
+\ex{PORT} & change connection port \\
+\ex{PWD}  & return name of working directory (print working directory) \\
+\ex{QUIT} & quit session \\
+\ex{RETR} & return file (GET) \\
+\ex{RMD} & remove directory \\
+\ex{RNFR} & read in the name of a file to be renamed (use \ex{RNTO} next) \\
+\ex{RNTO} & rename file mentioned before in a \ex{RNFR} command \\
+\ex{SIZE} & return size of a regular file \\
+\ex{STOR} & store file (PUT) \\
+\ex{STRU}& change structure to transfer files 
+           (only the file structure is supported) \\
+\ex{SYST} & return system type \\
+\ex{TYPE} & change type (supported types: A is ascii mode, 
+            I or L8 are 8-bit binary mode) \\
+\ex{USER} & login user (only anonymous logins allowed, 
+            use ``anonymous'' or ``ftp'' as user name) \\
+\hline
+\end{tabular}
+\caption{Supported RFC~959 commands by the server.}
+\end{center}
+\end{table}
+
+
+%\subsection{What programmers want to know}
+
+%Let me know what you want to know. As long as you are waiting for my
+%answer, have a look in the source file (I'm sorry).
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: man.tex
+%%% End: 

doc/latex/httpd.tex

@@ -0,0 +1,464 @@
+\chapter{HTTP server}\label{cha:httpd}
+%
+\begin{description}
+\item[Used files:] httpd/core.scm, httpd/handlers.scm, httpd/options.scm,
+\item[Name of the packages:] httpd-core, httpd-basic-handler, httpd-make-options
+\end{description}
+There are also some other files and packages that are used internally.
+                                %
+
+The SUnet web system is a collection of packages of \Scheme code that
+provides utilities for interacting with the World-Wide Web.  This
+includes:
+\begin{itemize}
+\item A Web server.
+\item URI and URL parsers and un-parsers (see Chapters \ref{cha:uri}
+  and \ref{cha:url}).
+\item RFC822-style header parsers (see Chapter \ref{cha:rfc822}).
+\item Code for performing structured html output
+\item Code to assist in writing CGI \Scheme programs that can be used by
+  any CGI-compliant HTTP server (such as NCSA's httpd, or the SUnet
+  Web server).
+\end{itemize}
+       
+The server has three main design goals:
+\begin{description}
+\item[Extensibility]
+  The server is in fact nothing but extensions, using a mechanism
+  called ``path handlers'' to define URL-specific services. It has a
+  toolkit of services that can be used as-is, extended or built
+  upon. User extensions have exactly the same status as the base
+  services.
+  
+  The extension mechanism allows for easy implementation of new
+  services without the overhead of the CGI interface.  Since the
+  server is written on top of the Scheme shell, the full set of Unix
+  system calls and program tools is available to the implementor.
+  
+\item[Mobile code]
+  The server allows Scheme code to be uploaded for direct execution
+  inside the server. The server has complete control over the code,
+  and can safely execute it in restricted environments that do not
+  provide access to potentially dangerous primitives (such as the
+  ``delete file'' procedure.)
+  
+\item[Clarity]
+  I\footnote{That's Olin Shivers (\ex{shivers@ai.mit.edu},
+    \ex{http://www.\ob{}ai.\ob{}mit.\ob{}edu/\ob{}people/\ob{}shivers/}).
+    For the rest of the documentation, if not mentioned otherwise,
+    `I' refers to him.} wrote this server to help myself understand
+  the Web. It is voluminously commented, and I hope it will prove to
+  be an aid in understanding the low-level details of the Web
+  protocols.
+  
+    The SUnet web server has the ability to upload code from Web clients
+    and execute that code on behalf of the client in a protected
+    environment.
+          
+    Some simple documentation on the server is available.
+  \end{description}
+
+\section{Basic server structure}
+  
+The Web server is started by calling the httpd procedure, which takes
+one argument, a \ex{httpd\=options}-record:
+
+\defun{httpd}{options}{\noreturn}
+\begin{desc}
+  This procedure starts the server. The various \semvar{options} can
+  be set via the options transformers that are explained below.
+  
+  The server's basic loop is to wait on the port for a connection from
+  an HTTP client. When it receives a connection, it reads in and
+  parses the request into a special request data structure. Then the
+  server forks a thread, who binds the current I/O ports to the
+  connection socket, and then hands off to the top-level
+  \semvar{path-handler} (the first argument to httpd). The
+  \semvar{path-handler} procedure is responsible for actually serving
+  the request -- it can be any arbitrary computation.  Its output goes
+  directly back to the HTTP client that sent the request.
+   
+  Before calling the path handler to service the request, the HTTP
+  server installs an error handler that fields any uncaught error,
+  sends an error reply to the client, and aborts the request
+  transaction.  Hence any error caused by a path-handler will be
+  handled in a reasonable and robust fashion.
+   
+  The basic server loop, and the associated request data structure are
+  the fixed architecture of the SUnet Web server; its flexibility lies
+  in the notion of path handlers.
+\end{desc}
+
+\defun{with-port}{port \ovar{options}}{options}
+\defunx{with-root-directory}{root-directory
+  \ovar{options}}{options} 
+\defunx{with-fqdn}{fqdn \ovar{options}}{options}
+\defunx{with-reported-port}{reported-port
+  \ovar{options}}{options}
+\defunx{with-path-handler}{path-handler
+  \ovar{options}}{options}
+\defunx{with-server-admin}{mail-address
+  \ovar{options}}{options}
+\defunx{with-simultaneous-requests}{requests
+  \ovar{options}}{options}
+\defunx{with-logfile}{logfile \ovar{options}}{options}
+\defunx{with-syslog?}{syslog? \ovar{options}}{options}
+\defunx{with-resolve-ip?}{resolve-ip? \ovar{options}}{options}
+\begin{desc}
+  As noted above, these transformers set the options for the web
+  server. Every transformer changes one aspect of the
+  \semvar{options} (for the \ex{httpd}). If this optional argument is missing, the
+  default values are used. These are the following:
+
+  \begin{tabular}{ll}
+    \bf{transformer} & \bf{default value} \\
+    \hline
+    \ex{with\=port} & 80 \\
+    \ex{with\=root\=directory} & ``\ex{/}'' \\
+    \ex{with\=fqdn} & \sharpf \\
+    \ex{with\=reported-port} & \sharpf \\
+    \ex{with\=path\=handler} & \sharpf \\
+    \ex{with\=server\=admin} & \sharpf \\
+    \ex{with\=simultaneous\=requests} & \sharpf \\
+    \ex{with\=logfile} & ``\ex{/logfile.log}''\\
+    \ex{with\=syslog?} & \sharpt \\
+    \ex{with\=resolve\=ip?} & \sharpt
+  \end{tabular}
+
+%  that can be found in the \ex{httpd\=make\=options}-structure:
+%  \ex{with\=port}, \ex{with\=root\=directory}, \ex{with\=fqdn},
+%  \ex{with\=reported-port}, \ex{with\=path\=handler},
+%  \ex{with\=server\=admin}, \ex{with\=simultaneous-requests},
+%  \ex{with\=logfile}, \ex{with\=syslog?} that set the port the server
+%  is listening to, the root-directory of the server, the FQDN of the
+%  server, the port the server assumes it is listening to, the
+%  path-handler of the server (see below), the mail-address of the
+%  server-admin, the maximum number of simultaneous handled requests,
+%  the name of the file or the port logging in the Common Log Format
+%  (CLF) is output to and if the server shall create syslog messages,
+%  respectively. The port defaults to 80, the root directory defaults
+%  to ``\ex{/}'', the mail address of the server-admin defaults to
+%  ``\ex{sperber@\ob{}informatik.\ob{}uni\=tuebingen.\ob{}de}'',
+%  \FIXME{Why does the server admin mail address have
+%   sperber@informatik... as default value?}logging is done to
+%  ``\ex{httpd.log}'' and syslog is enabled. All other options default
+%  to \sharpf.
+
+  For example
+\begin{alltt}
+(httpd (with-path-handler 
+        (rooted-file-handler "/usr/local/etc/httpd")
+        (with-root-directory "/usr/local/etc/httpd")))
+\end{alltt}
+  
+  starts the server on port 80 with
+  ``\ex{/usr/\ob{}local/\ob{}etc/\ob{}httpd}'' as root directory and
+  lets it serve any file out from this directory.
+  \ex{rooted\=file\=handler} creates a path handler and is explained
+  below. You see, the transformers are used nested. So, every
+  transformer changes one aspect of the options that the following
+  transformer returns and the last transformer (here:
+  \ex{with\=root\=directory}) changes an aspect of the default values
+
+  
+  \semvar{port} is the port the server is listening to,
+  \semvar{root-directory} is the directory in the file system the
+  server uses as root, \semvar{fqdn} is the fully qualified domain
+  name the server reports, \semvar{reported-port} is the port the
+  server reports it is listening to and \semvar{server-admin} is the
+  mail address of the server admin. \semvar{requests} denote the
+  maximum number of allowed simultaneous requests to the server.
+  \sharpf\ means infinite. \semvar{logfile} is either a string, then
+  it is the file name of the logfile, or a port, where the log entries
+  are written to, or \sharpf, that means no logging is made. The
+  logfile is in Common Log Format (CLF). To allow rotation of
+  logfiles, the server will reopen the logfile when it receives the
+  signal \texttt{USR1}. \semvar{syslog?}  tells the server to write
+  syslog messages (\sharpt) or not (\sharpf).
+\end{desc}   
+
+\section{Path handlers}
+\label{httpd:path-handlers}
+  
+   A path handler is a procedure taking two arguments:
+\defun{path-handler}{path req}{value}
+\begin{desc}
+  The \semvar{req} argument is a request record giving all the details
+  of the client's request; it has the following structure: \FIXME{Make
+    the record's structure a table}
+\begin{alltt}
+(define-record request
+ method            ; A string such as "GET", "PUT", etc.
+ uri               ; The escaped URI string as read from request line.
+ url               ; An http URL record (see url.scm).
+ version           ; A (major . minor) integer pair.
+ headers           ; An rfc822 header alist (see rfc822.scm).
+ socket)           ; The socket connected to the client.
+\end{alltt}
+
+The \semvar{path} argument is the URL's path, parsed and split at
+slashes into a string list. For example, if the Web client
+dereferences URL
+\codex{http://\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu:\ob{}8001/\ob{}h/\ob{}shi\ob{}vers/\ob{}co\ob{}de/\ob{}web.\ob{}tar.\ob{}gz}
+then the server would pass the following path to the top-level
+handler: \ex{("h"\ob{} "shivers"\ob{} "code"\ob{}
+  "web.\ob{}tar.\ob{}gz")}
+
+The \semvar{path} argument's pre-parsed representation as a string
+list makes it easy for the path handler to implement recursive
+operations dispatch on URL paths.
+\end{desc}
+   
+Path handlers can do anything they like to respond to HTTP requests;
+they have the full range of Scheme to implement the desired
+functionality. When handling HTTP requests that have an associated
+entity body (such as POST), the body should be read from the current
+input port. Path handlers should in all cases write their reply to the
+current output port. Path handlers should not perform I/O on the
+request record's socket. Path handlers are frequently called
+recursively, and doing I/O directly to the socket might bypass a
+filtering or other processing step interposed on the current I/O ports
+by some superior path handler.
+
+\section{Basic path handlers}
+  
+Although the user can write any path-handler he likes, the SUnet web server
+comes with a useful toolbox of basic path handlers that can be used
+and built upon (exported by the \ex{httpd\=basic\=handlers}-structure):
+   
+\begin{defundesc}{alist-path-dispatcher}{ph-alist default-ph}{path-handler}
+  This procedure takes a \ex{string->\ob{}path\=handler} alist, and a
+  default path handler, and returns a handler that dispatches on its
+  path argument. When the new path handler is applied to a path
+  \ex{("foo"\ob{} "bar"\ob{} "baz")}, it uses the first element of
+  the path -- ``\ex{foo}'' -- to index into the alist. If it finds an
+  associated path handler in the alist, it hands the request off to
+  that handler, passing it the tail of the path, \ex{("bar"\ob{}
+    "baz")}. On the other hand, if the path is empty, or the alist
+  search does not yield a hit, we hand off to the default path
+  handler, passing it the entire original path, \ex{("foo"\ob{}
+    "bar"\ob{} "baz")}.
+          
+  This procedure is how you say: ``If the first element of the URL's
+  path is `foo', do X; if it's `bar', do Y; otherwise, do Z.'' If one
+  takes an object-oriented view of the process, an alist path-handler
+  does method lookup on the requested operation, dispatching off to
+  the appropriate method defined for the URL.
+          
+  The slash-delimited URI path structure implies an associated tree of
+  names. The path-handler system and the alist dispatcher allow you to
+  procedurally define the server's response to any arbitrary subtree
+  of the path space.
+          
+  Example: A typical top-level path handler is
+\begin{alltt}          
+(define ph
+  (alist-path-dispatcher
+      `(("h"       . ,(home-dir-handler "public\_html"))
+        ("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))
+        ("seval"   . ,seval-handler))
+      (rooted-file-handler "/usr/local/etc/httpd/htdocs")))
+\end{alltt}
+    
+    This means:
+\begin{itemize}          
+\item If the path looks like \ex{("h"\ob{} "shivers"\ob{}
+    "code"\ob{} "web.\ob{}tar.\ob{}gz")}, pass the path
+  \ex{("shivers"\ob{} "code"\ob{} "web.\ob{}tar.\ob{}gz")} to a
+  home-directory path handler.
+\item If the path looks like \ex{("cgi-\ob{}bin"\ob{} "calendar")},
+    pass ("calendar") off to the CGI path handler.
+  \item If the path looks like \ex{("seval"\ob{} \ldots)}, the tail
+    of the path is passed off to the code-uploading seval path
+    handler.
+  \item Otherwise, the whole path is passed to a rooted file handler,
+    who will convert it into a filename, rooted at
+    \ex{/usr/\ob{}lo\ob{}cal/\ob{}etc/\ob{}httpd/\ob{}htdocs},
+    and serve that file.
+\end{itemize}
+\end{defundesc}
+            
+\begin{defundesc}{home-dir-handler}{subdir}{path-handler}
+  This procedure builds a path handler that does basic file serving
+  out of home directories. If the resulting \semvar{path-handler} is
+  passed a path of \ex{(user . file\=path)}, then it serves the file
+  \ex{user's\=ho\ob{}me\=di\ob{}rec\ob{}to\ob{}ry/\ob{}sub\ob{}dir/\ob{}file\=path}
+    
+  The path handler only handles GET requests; the filename is not
+  allowed to contain \ex{..} elements.
+\end{defundesc}
+          
+\begin{defundesc}{tilde-home-dir-handler}{subdir default-path-handler}{path-handler}
+  This path handler examines the car of the path. If it is a string
+  beginning with a tilde, e.g., \ex{"~ziggy"}, then the string is
+  taken to mean a home directory, and the request is served similarly
+  to a home-dir-handler path handler. Otherwise, the request is passed
+  off in its entirety to the \semvar{default-path-handler}.
+          
+  This procedure is useful for implementing servers that provide the
+  semantics of the NCSA httpd server.
+\end{defundesc}
+          
+\begin{defundesc}{cgi-handler}{cgi-directory}{path-handler}
+  This procedure returns a path-handler that passes the request off to
+  some program using the CGI interface. The script name is taken from
+  the car of the path; it is checked for occurrences of \ex{..}'s. If
+  the path is \ex{("my\=prog"\ob{} "foo"\ob{} "bar")} then the
+  program executed is
+  \ex{cgi\=di\ob{}rec\ob{}to\ob{}ry\ob{}my\=prog}.
+
+  When the CGI path handler builds the process environment for the CGI
+  script, several elements (e.g., \ex{\$PATH and \$SERVER\_SOFTWARE}) are request-invariant, and can be
+  computed at server start-up time. This can be done by calling
+  \codex{(initialise-request-invariant-cgi-env)} 
+  when the server starts up. This is not necessary, but will make CGI
+  requests a little faster.
+\end{defundesc}
+          
+\begin{defundesc}{rooted-file-handler}{root-dir}{path-handler} 
+  Returns a path handler that serves files from a particular root in
+  the file system. Only the GET operation is provided. The path
+  argument passed to the handler is converted into a filename, and
+  appended to root-dir.  The file name is checked for \ex{..}
+  components, and the transaction is aborted if it does.  Otherwise,
+  the file is served to the client.
+\end{defundesc}
+
+\begin{defundesc}{rooted-file-or-directory-handler}{root
+icon-name}{path-handler} 
+
+Dito, but also serve directory indices for directories without
+\ex{index.\ob{}html}. \semvar{icon-name} specifies how to generate
+the links to various decorative icons for the listings.  It can either
+be a procedure which gets passed one of the icon tags listed below and
+is expected to return a link pointing to the icon.  If it is a string,
+that is taken as prefix to which the file names of the tags listed
+below are appended.
+
+\begin{tabular}{ll}
+Tag & Icon's file name \\
+\hline
+\ex{directory} & \ex{directory.xbm}\\
+\ex{text} & \ex{text.xbm}\\
+\ex{doc} & \ex{doc.xbm}\\
+\ex{image} & \ex{image.xbm}\\
+\ex{movie} & \ex{movie.xbm}\\
+\ex{audio} & \ex{sound.xbm}\\
+\ex{archive} & \ex{tar.xbm}\\
+\ex{compressed} & \ex{compressed.xbm}\\
+\ex{uu} & \ex{uu.xbm}\\
+\ex{binhex} & \ex{binhex.xbm}\\
+\ex{binary} & \ex{binary.xbm}\\
+\ex{blank} & \ex{blank.xbm}\\
+\ex{back} & \ex{back.xbm}\\
+\ex{\it{}else} & \ex{unknown.xbm}\\
+\end{tabular}
+\end{defundesc}
+          
+\begin{defundesc}{null-path-handler}{path req}{\noreturn}
+  This path handler is useful as a default handler. It handles no
+  requests, always returning a ``404 Not found'' reply to the client.
+\end{defundesc}
+          
+\section{HTTP errors}
+  
+Authors of path-handlers need to be able to handle errors in a
+reasonably simple fashion. The SUnet Web server provides a set of error
+conditions that correspond to the error replies in the HTTP protocol.
+These errors can be raised with the \ex{http\=error} procedure. When
+the server runs a path handler, it runs it in the context of an error
+handler that catches these errors, sends an error reply to the client,
+and closes the transaction.
+   
+\begin{defundesc}{http-error}{reply-code req \ovar{extra \ldots}}{\noreturn}
+  This raises an http error condition. The reply code is one of the
+  numeric HTTP error reply codes, which are bound to the variables
+  \ex{http\=re\ob{}ply/\ob{}ok, http\=re\ob{}ply/\ob{}not\=found,
+    http\=re\ob{}ply/\ob{}bad\=request}, and so forth. The
+  \semvar{req} argument is the request record that caused the error.
+  Any following extra args are passed along for informational
+  purposes. Different HTTP errors take different types of extra
+  arguments. For example, the ``301 moved permanently'' and ``302
+  moved temporarily'' replies use the first two extra values as the
+  \ex{URI:} and \ex{Lo\-ca\-tion:} fields in the reply header,
+  respectively. See the clauses of the
+  \ex{send\=http\=er\ob{}ror\=re\ob{}ply} procedure for details.
+\end{defundesc}
+          
+\begin{defundesc}{send-http-error-reply}{reply-code request \ovar{extra \ldots}}{\noreturn}
+  This procedure writes an error reply out to the current output port.
+  If an error occurs during this process, it is caught, and the
+  procedure silently returns. The http server's standard error handler
+  passes all http errors raised during path-handler execution to this
+  procedure to generate the error reply before aborting the request
+  transaction.
+\end{defundesc}
+          
+\section{Simple directory generation}
+  
+Most path-handlers that serve files to clients eventually call an
+internal procedure named \ex{file\=serve}, which implements a simple
+directory-generation service using the following rules:
+\begin{itemize}
+\item If the filename has the form of a directory (i.e., it ends with
+  a slash), then \ex{file\=serve} actually looks for a file named
+  ``index.html'' in that directory.
+\item If the filename names a directory, but is not in directory form
+  (i.e., it doesn't end in a slash, as in
+  ``\ex{/usr\ob{}in\ob{}clu\ob{}de}'' or ``\ex{/usr\ob{}raj}''),
+  then \ex{file\=serve} sends back a ``301 moved permanently''
+  message, redirecting the client to a slash-terminated version of the
+  original URL. For example, the URL
+  \ex{http://\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu/\ob{}~shi\ob{}vers}
+  would be redirected to
+  \ex{http://\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu/\ob{}~shi\ob{}vers/}
+\item If the filename names a regular file, it is served to the
+  client.
+\end{itemize}
+ 
+\section{CGI Server}
+
+\begin{defundesc}{cgi-handler}{bin-dir \ovar{cgi-bin-dir}}{path-handler}
+  Returns a path handler (see \ref{httpd:path-handlers} for details
+  about path handlers) for cgi-scripts located in
+  \semvar{bin-dir}. \semvar{cgi-bin-dir} specifies the value of the
+\ex{PATH} variable of the environment the cgi-scripts run in. It defaults
+to
+``\ex{/bin:\ob{}/usr/bin:\ob{}/usr/ucb:\ob{}/usr/bsd:\ob{}/usr/local/bin}''
+but is overwritten by the current \ex{PATH} environment variable at
+the time \ex{cgi-handler} ist called. The cgi-scripts are called as
+specified by CGI/1.1\footnote{see
+\ex{http://hoohoo.ncsa.uiuc.edu/cgi/interface.html} for a sort of
+specification.}. 
+
+\begin{itemize}
+\item Various environment variables are set (like
+  \ex{QUERY\_STRING} or \ex{REMOTE\_HOST}).
+\item ISINDEX queries get their arguments as command line arguments.
+\item Scripts are handled differently according to their name:
+
+  \begin{itemize}
+
+    \item If the name of the script starts with `\ex{nph-}', its reply
+    is read, the RFC~822-fields like ``Content-Type'' and ``Status''
+    are parsed and the client is sent back a real HTTP reply,
+    containing the rest of the script's output.  
+
+    \item If the name of the script doesn't start with `\ex{nph-}',
+    its output is sent back to the client directly. If its return code
+    is not zero, an error message is generated.
+
+\end{itemize}
+\end{itemize}
+\end{defundesc}      
+
+\section{Support procs}
+  
+The source files contain a host of support procedures which will be of
+utility to anyone writing a custom path-handler. Read the files first.
+\FIXME{Let us read the files and paste the contents here.}
+   
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: "man"
+%%% End: 

doc/latex/intro.tex

@@ -0,0 +1,70 @@
+\chapter{Overview}\label{sec:intro}
+
+\section{What's in SUnet?}
+
+The Scheme Underground Network Package contains a set of libraries for
+doing Net hacking from Scheme/scsh. It includes:
+   
+\begin{description}
+\item[The SUnet Web server]
+  This is a complete implementation of an HTTP 1.0 server in Scheme.
+  The server contains other standalone packages that may separately be
+  of use:
+  \begin{itemize}
+  \item URI and URL parsers and unparsers.
+  \item A library to help writing CGI scripts in Scheme.
+  \item Server extensions for interfacing to CGI scripts.
+  \item Server extensions for uploading Scheme code.
+  \item Simple structured HTML output library
+  \end{itemize}            
+\item[The SUnet ftp daemon]
+  This is a complete ftp server in Scheme.
+\item[ftp client library] Access an ftp server programmatically.
+\item[SMTP client library]
+  Forge mail from the comfort of your own Scheme process.
+\item[POP3 client library]
+  Get at your mails from inside scsh.
+\item[RFC822 header library]
+  Read email-style headers. Useful in several contexts (smtp, http,
+  etc.)
+\item[Daytime and Time protocol client library]
+  Find out what time it is without paying for a Rolex.
+\item[An \texttt{ls} clone] Display Unix-style directory listings
+  without running \texttt{ls}.
+\end{description}
+
+\section{Obtaining the system}
+
+The SUnet code is available
+\urlhd{http://www.scsh.net/sunet/}{here}{from
+  \url{http://www.scsh.net/sunet/}}.  To run the code, you need
+version 0.6.3 or later of \urlhd{http://www.scsh.net/}{scsh}{scsh from
+  \url{http://www.scsh.net/}}.
+
+\section{How to use the packages}
+
+Scsh is started in the SUnet top-level directory. Then, the
+description file of the modules is loaded and the \texttt{ftp} module
+is opened (to use a ftp client). After the things are done, scsh is
+finished via the \verb|,exit| command.
+%
+\begin{alltt}
+atari-2600[72] scsh-0.6.2
+Welcome to scsh 0.6.2 (Gambit-C 4.0)
+Type ,? for help.
+> ,config ,load packages.scm
+modules.scm
+> ,open ftp
+Load structure ftp (y/n)? y
+[ecm-utilities ecm-utilities.scm]
+[netrc netrc.scm]
+[ftp ftp.scm]
+> ; call library code
+> ,exit
+atari-2600[73]
+\end{alltt}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: "man"
+%%% End: 

doc/latex/man.tex

@@ -0,0 +1,39 @@
+\documentclass{report}
+
+\usepackage[latin1]{inputenc}
+\usepackage{alltt}
+\usepackage{tex2page}
+
+\author{Olin Shivers \and Mike Sperber \and Martin Gasbichler \and
+  Andreas Bernauer}
+\title{The Scheme Untergrund Networking Package}
+
+\input{decls}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+  \noindent The Scheme Untergrund Network Package (\textit{SUnet} for short) is
+  a set of libraries for Internet hacking.  Among the implemented
+  protocols are server-side http, client-side ftp, server-side ftp,
+  client-side DNS, client-side nettime, client-side POP3, client-side
+  SMTP.  SUnet also contains a number of libraries for Web
+  programming: a small package for outputting HTML, a CGI library, as
+  well as some other utilities.
+\end{abstract}
+\tableofcontents
+
+\include{intro}
+\include{httpd}
+\include{toothless}
+\include{cgi-script}
+\include{ftpd}
+\include{ftp}
+\include{netrc}
+\include{uri}
+\include{url}
+\include{rfc822}
+\include{nettime}
+\include{smtp}
+\include{pop3}
+\end{document}

doc/latex/netrc.tex

@@ -0,0 +1,142 @@
+\chapter{Reading netrc-files}\label{cha:netrc}
+%
+\begin{description}
+\item[Used files:] netrc.scm
+\item[Name of the package:] netrc
+\end{description}
+%
+\section{Overview}
+This module provides procedures to parse authentication information
+contained in \ex{~/.netrc}.
+
+On Unix systems the \ex{~/.netrc} file (in the user's home directory)
+may contain information allowing automatic login to remote hosts.  The
+format of the file is defined in the \ex{ftp}(1) manual page.  Example
+lines are
+\begin{alltt}
+machine ondine.cict.fr login marsden password secret
+default login anonymous password user@site%
+\end{alltt}
+
+The \ex{~/.netrc} file should be protected by appropriate permissions, and
+(like \ex{/usr/bin/ftp}) this library will refuse to read the file if it is
+badly protected. (unlike \ex{ftp} this library will always refuse
+to read the file -- \ex{ftp} refuses it only if the password is
+given for a non-default account). Appropriate permissions are set if
+only the user has permissions on the file.
+
+Note following restrictions and differences:
+\begin{itemize}
+\item The macdef statement (defining macros) is not supported.
+\item The settings for one machine must be on a single line.
+\item The is no error proof while reading the file.
+\item Default need not be the last line of the netrc-file.
+\end{itemize}
+
+
+
+\section{Entry points}
+
+What you probably want, is to read out the default netrc-file. Do the
+following:
+\begin{alltt}
+ (let ((netrc-record (netrc:parse)))
+    (netrc:lookup netrc-record "name of the machine")) 
+\end{alltt}
+ 
+and you will receive three values: \semvar{login-name},
+\semvar{password} and \semvar{account-name}. If you only want the
+login name or the password, use \ex{netrc:\ob{}lookup\=login} or
+\ex{netrc:\ob{}lookup\=password}, resp.
+
+You will get either the login / password for the specified machine, or
+a default login / password if the machine is unknown.
+
+
+\begin{defundesc}{user-mail-address}{}{string}
+  Calculate the user's email address, as per the Emacs function of the
+  same name. Will take into account the environment variable
+  \ex{REPLYTO}, if set. Otherwise the mail-address will look like
+  \ex{user@\ob{}hostname}.
+\end{defundesc}
+
+\defun{netrc:parse} {\ovar{filename \ovar{fallback-password
+      \ovar{fallback-login}}}} {netrc-record}
+\begin{defundescx}{netrc:try-parse} {filename fallback-password
+    fallback-login} {netrc-record}
+        
+  \ex{netrc:parse} parses the netrc file and returns a \ex{netrc}
+  record, containing all necessary information for the following
+  procedures.
+  
+  \semvar{filename} defaults to ``~/.netrc'',
+  \semvar{fallback-password} defaults to the result of the call to
+  \ex{user\=mail\=address} and \semvar{fallback-login} defaults to
+  ``anonymous''. If the netrc file does not provide a default password
+  or a default login (stated by the ``default'' statement),
+  \semvar{fallback-password} and \semvar{fallback-login} will be used
+  as default password or login, respectively (thus,
+  \ex{user\=mail\=address} is only called if the netrc file does not
+  contain a default specification).  If the netrc file does not exist,
+  a netrc-record filled with default values is returned.  If the netrc
+  file does not have the correct permissions, a message is printed to
+  the current error port and a netrc-record filled with default values
+  is returned.
+  
+  \ex{netrc:try-parse} does the same as \ex{netrc:\ob{}parse}, except
+  of the following: if there is no file called \semvar{filename}, the
+  according error will be raised and if the specified file does not
+  have the correct permissions set, a \ex{netrc\=refuse\=warning} will
+  be signalled. So, if you don't like the error handling and behavior
+  of \ex{netrc:\ob{}parse}, use \ex{netrc:\ob{}try\=parse} and catch
+  the signalled conditions. Note, that \ex{netrc:\ob{}parse} resolves
+  \semvar{filename} for you, \ex{netrc:\ob{}try-parse} does not -- you
+  have to do it on your own.
+\end{defundescx}
+
+\defun{netrc:lookup}{netrc-record machine \ovar{default?}} {string
+  string string}
+\defunx{netrc:lookup-password}{netrc-record machine
+  \ovar{default?}}{string}
+\defunx{netrc:lookup-login}{netrc-record machine
+  \ovar{default?}}{string}
+\begin{desc}
+  Return the login, password and / or account information for
+  \semvar{machine} specified by \semvar{netrc-record}, respectively.
+  If \semvar{default?} is \sharpt, default values are returned if no
+  such \semvar{machine} is specified in the \semvar{netrc-record}.
+  Otherwise [\sharpf\ \sharpf\ \sharpf] or \sharpf\ is returned,
+  respectively.
+\end{desc}
+
+\defun{netrc:default-login}{netrc-record}{string}
+\begin{defundescx}{netrc:default-password}{netrc-record}{string}
+  Return the default values for the login or the password, respectively,
+  specified by \semvar{netrc-record}. If the netrc file did not
+  specify a default login, ``anonymous'' is returned by
+  \ex{netrc:\ob{}default\=login}. If the netrc file did not specify a
+  default password, the result of the call to \ex{user\=mail\=address}
+  is returned by \ex{netrc:\ob{}default\=password}.
+\end{defundescx}
+
+\section{Related work}
+\begin{itemize}
+\item Graham Barr has written a similar library for Perl, called
+  \ex{Netrc.pm}.
+\item \ex{ange-ftp.el} (transparent remote file access for Emacs)
+  parses the user's netrc file.
+\end{itemize}
+
+\section{Desirable things}
+\begin{itemize}
+\item Remove restrictions (as stated in `\emph{Overview}') and behave like
+   \ex{/usr/\ob{}bin/\ob{}ftp} behaves
+\item perhaps: adding case-insensitivity (for host names)
+\item perhaps: better record-disclosers for netrc-entry- and
+  netrc-records
+\end{itemize}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: "man"
+%%% End: 

doc/latex/nettime.tex

@@ -0,0 +1,60 @@
+\chapter{Using Time and Daytime Protocol}\label{cha:ntp}
+%
+\begin{description}
+\item[Used files:] nettime.scm nettime-obsolete.scm
+\item[Name of the package:] nettime nettime-obsolete
+\end{description}
+%
+
+\subsection{Overview}
+Most Unix hosts provide a Daytime service which sends the current date
+and time as a human-readable character string. The daytime service is
+typically served on port 13 as both TCP and UDP.
+
+The Time protocol provides a site-independent, machine readable date
+and time. A ``time'' consists of the number of seconds since midnight on
+1st January 1900. The Time service is typically served on port 37 as
+TCP and UDP. The idea is that you can confirm your system's idea of
+the time by polling several independent sites on the network.
+
+\subsection{Procedures}
+
+\begin{defundesc}{net-time}{host tcp/udp}{integer}
+  Asks \semvar{host} about the current time. \semvar{tcp/udp} is
+  either \ex{socket\=type/\ob{}stream} or
+  \ex{socket\=type/\ob{}datagram}, that indicate TCP or UDP
+  connection, respectively (depends on the server).\FIXME{Is it
+    correct, that the tcp/udp argument describes TCP or UDP use via
+    socket-type/stream or socket-type/datagram, resp.?} The number of
+  second since 1970 is returned, since the time protocol returns the
+  number of seconds since 1900, whereas Unix time is since 1970. The
+  difference between both answers is 2208988800.
+\end{defundesc}
+
+\begin{defundesc}{net-daytime}{host tcp/udp}{string}
+  Asks \semvar{host} about the current daytime. \semvar{tcp/udp} is
+  the same as in \ex{net:time}, indicating to use TCP or UDP. The
+  host's answer is returned (e.g., ``Thursday, April 4, 2'').
+\end{defundesc}
+
+\subsubsection*{Obsolete procedures}
+
+Names in further versions of \ex{nettime} contained a colon (`\ex{:}')
+after the prefix `\ex{net-}'. This is now changed to a hyphen
+('\ex{-}'), accordingly to SUnet's philosophy. If you need the old
+names, use the \ex{nettime\=obsolete}-package that maps the old names
+to the new ones.
+
+\subsection{Related work}
+\begin{itemize}
+\item \ex{Time.pm} is a Perl module by Graham Barr
+\item RFC~868 describes the Time protocol
+\item RFC~867 describes the Daytime protocol in all its glory
+\item For a genuinely useful protocol look at the Network Time
+  Protocol defined in RFC~1305, which allows for the synchronization
+  of clocks on networked computers.
+\end{itemize}
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 

doc/latex/pop3.tex

@@ -0,0 +1,121 @@
+\section{Using POP3}\label{cha:pop3}
+%
+\begin{description}
+\item[Used files:] pop3.scm pop3-obsolete.scm
+\item[Name of the package:] pop3 pop3-obsolete.scm
+\end{description}
+%
+\section{Overview}
+
+The POP3 protocol allows access to email on a maildrop server. It is
+often used in configurations where users connect from a client machine
+which doesn't have a permanent network connection or isn't always
+turned on, situations which make local SMTP delivery impossible. It is
+the most common form of email access provided by Internet Service
+Providers.
+
+Two types of authentication are commonly used. The first, most basic
+type involves sending a user's password in clear over the network, and
+should be avoided. Unfortunately many POP3 clients only implement this
+basic authentication. The digest authentication system involves the
+server sending the client a ``challenge'' token; the client encodes
+this token with the pass phrase and sends the coded information to the
+server. This method avoids sending sensitive information over the
+network.
+
+Once connected, a client may request information about the number and
+size of the messages waiting on the server, download selected messages
+(either their headers or the entire content), and delete selected
+messages.
+
+
+\section{Entry points}
+
+\begin{defundesc}{pop3-connect}{\ovar{host \ovar{logfile}}}{connection}
+  Connect to the maildrop server named \semvar{host}. Optionally log
+  the conversation with the server to \semvar{logfile}, which will be
+  appended to if it exists, and created otherwise. The environment
+  variable \ex{MAILHOST}, if set, will override the value of
+  \semvar{host}.
+\end{defundesc}
+
+In the further descriptions of the procedures, \semvar{connection}
+always refers to the result of \ex{pop3-\ob{}connect}.
+
+\begin{defundesc}{pop3-login} {connection \ovar{login \ovar{password}}}{status}
+  Log in to the mailhost. If a \semvar{login} and \semvar{password}
+  are not provided, they are first searched for in the user's ~/.netrc
+  file. USER/PASS authentication will be tried first, and if
+  this fails, APOP authentication (secure) will be tried.
+\end{defundesc}
+
+\begin{defundesc}{pop3-login/APOP} {connection login password}{status}
+  Log in to the mailhost using APOP authentication\footnote{The encryption
+  (MD5) is currently done by an extern program that your system must
+  provide. The expected name of the program is \ex{md5sum}. If your system
+  uses another program for computing a MD5 message digest, change the
+  program's name in \ex{md5-digest}.}.
+\end{defundesc}
+
+\begin{defundesc}{pop3-stat}{connection}{number bytes}
+  Return the number of messages and the number of bytes waiting in the
+  maildrop.
+\end{defundesc}
+
+\begin{defundesc}{pop3-get}{connection msgid}{status}
+  Download message number \semvar{msgid} from the mailhost.
+  \semvar{msgid} must be positive and less than the number of messages
+  returned by the \ex{pop3-\ob{}stat} call. The message contents are sent to
+  \ex{(cur\ob{}rent-\ob{}out\ob{}put-\ob{}port)}.
+\end{defundesc}
+
+\begin{defundesc}{pop3-headers}{connection msgid}{status}
+  Download the headers of message number \semvar{msgid}. The data is sent to
+  \ex{(cur\ob{}rent-\ob{}out\ob{}put-\ob{}port)}.
+\end{defundesc}
+
+\begin{defundesc}{pop3-last}{connection}{msgid}
+  Return the highest accessed message-id number for the current
+  session. This isn't in the RFC, but seems to be supported by several
+  servers.
+\end{defundesc}
+
+\begin{defundesc}{pop3-delete}{connection msgid}{status}
+  Mark message number \semvar{msgid} for deletion. The message will
+  not be deleted until the client logs out.
+\end{defundesc}
+
+\begin{defundesc}{pop3-reset}{connection}{status}
+  Any messages which have been marked for deletion are unmarked.
+\end{defundesc}
+
+\begin{defundesc}{pop3-quit}{connection}{status}
+  Close the connection with the mailhost.
+\end{defundesc}
+
+\subsubsection*{Obsolete procedures}
+
+Names in further versions of \ex{pop3} contained a colon (`\ex{:}')
+after the prefix `\ex{pop3-}'. This is now changed to a hyphen
+('\ex{-}'), accordingly to SUnet's philosophy. If you need the old
+names, use the \ex{pop3\=obsolete}-package that maps the old names to
+the new ones.
+
+\section{Related work}
+
+\begin{itemize}
+\item Emacs is distributed with a C program called \ex{movemail} which
+  can be compiled with support for the POP protocol. There is also an
+  Emacs Lisp library called \ex{pop3.el} by Richard Pieri which
+  includes APOP support.
+\item Shriram Krishnamurth has written a POP3 library for MzScheme (as
+  well as support for the NNTP protocol, for SMTP, \ldots).
+\item Siod (a small-footprint Scheme implementation by George Carette)
+  includes support for the POP3 protocol.
+\item rfc1939 describes the POP3 protocol.
+\end{itemize}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: "man"
+%%% End: 

doc/latex/rfc822.tex

@@ -0,0 +1,172 @@
+\chapter{Handle RFC822 headers}\label{cha:rfc822}
+%
+\begin{description}
+\item[Used files:] rfc822.scm
+\item[Name of the package:] rfc822
+\end{description}
+%
+\section{What users want to know}
+
+\section{A note on line-terminators}
+Line-terminating sequences are always a drag, because there's no
+agreement on them -- the Net protocols and DOS use
+carriage-return/line-feed (\ex{cr}/\ex{lf}); Unix uses \ex{lf}; the
+Mac uses \ex{cr}. One one hand, you'd like to use the code for all of
+the above, on the other, you'd also like to use the code for strict
+applications that need definitely not to recognise bare \ex{cr}'s or
+\ex{lf}'s as terminators.
+
+RFC 822 requires a \ex{cr}/\ex{lf} (carriage-return/line-feed) pair to
+terminate lines of text. On the other hand, careful perusal of the
+text shows up some ambiguities (there are maybe three or four of
+these, and I'm too lazy to write them all down). Furthermore, it is an
+unfortunate fact that many Unix apps separate lines of RFC~822 text
+with simple linefeeds (e.g., messages kept in \ex{/usr/spool/mail}).
+As a result, this code takes a broad-minded view of line-terminators:
+lines can be terminated by either \ex{cr}/\ex{lf} or just \ex{lf}, and
+either terminating sequence is trimmed.
+
+If you need stricter parsing, you can call the lower-level procedure
+\ex{\%read\=rfc822\=field} and \ex{\%read\=rfc822\=headers}. They take
+the read-line procedure as an extra parameter. This means that you can
+pass in a procedure that recognises only \ex{cr}/\ex{lf}'s, or only
+\ex{cr}'s (for a Mac app, perhaps), and you can determine whether or
+not the terminators get trimmed. However, your read-line procedure
+must indicate the header-terminating empty line by returning \emph{either}
+the empty string or the two-char string \ex{cr}/\ex{lf} (or the EOF object).
+
+\section{Description of the procedures}
+
+\defun{read-rfc822-field} {\ovar{port}} {name body}
+\begin{defundescx}{\%read-rfc822-field } {read-line port} {name body}
+  
+  Read one field from the port, and return two values:
+
+  \begin{description}
+  \item[\var{name}] Symbol such as \ex{'subject} or \ex{'to}. The
+    field name is converted to a symbol using the Scheme
+    implementation's preferred case. If the implementation reads
+    symbols in a case-sensitive fashion (e.g., scsh), lowercase is
+    used. This means you can compare these symbols to quoted constants
+    using \ex{eq?}. When printing these field names out, it looks best
+    if you capitalize them with \ex{(capitalize\=string (symbol->string field\=name))}.
+    
+  \item[\var{body}] List of strings which are the field's body, e.g.
+    (``shivers\discretionary{@}{}{@}lcs.mit.edu''). Each list element is one line from
+    the field's body, so if the field spreads out over three lines,
+    then the body is a list of three strings. The terminating
+    \ex{cr}/\ex{lf}'s are trimmed from each string. A leading space or
+    a leading horizontal tab is also trimmed, but one and onyl one.
+  \end{description}
+    
+  When there are no more fields -- EOF or a blank line has terminated
+  the header section -- then the procedure returns [\sharpf\ \sharpf].
+ 
+  The \ex{\%read-rfc822-field} variant allows you to specify your own
+  read-line procedure. The one used by \ex{read-rfc822-field}
+  terminates lines with either \ex{cr}/\ex{lf} or just \ex{lf}, and it
+  trims the terminator from the line. Your read-line procedure should
+  trim the terminator of the line, so an empty line is returned as an
+  empty string.
+  
+  The procedures raise an error if the syntax of the read field (the
+  line returned by the read-line-function) is illegal (regarding
+  RFC~822).
+\end{defundescx}
+
+\defun{read-rfc822-headers} {\ovar{port}} {association list}
+\begin{defundescx}{\%read-rfc822-headers} {read-line port}
+  {association list}
+  
+  Read in and parse up a section of text that looks like the header
+  portion of an RFC~822 message. Return an association list mapping a
+  field name (a symbol such as 'date or 'subject) to a list of field
+  bodies -- one for each occurence of the field in the header. So if
+  there are five ``Received-by:'' fields in the header, the alist maps
+  'received-by to a five element list. Each body is in turn
+  represented by a list of strings -- one for each line of the field.
+  So a field spread across three lines would produce a three element
+  body.
+  
+  The \ex{\%read-rfc822-headers} variant allows you to specify your
+  own read-line procedure. See \emph{A note on line-terminators} above
+  for reasons why.
+
+  Hint: If you want to get familiar with these procedures, you might
+  find \ex{make\=string\=input\=port}, that makes a port out of a
+  string, helpful.
+\end{defundescx}
+
+\begin{defundesc}{rejoin-header-lines} {alist \ovar{seperator}}
+  {association list}
+  
+  Takes a field \var{alist} such as is returned by
+  \ex{read-rfc822-headers} and returns an equivalent association list.
+  Each body (\str list) in the input \var{alist} is joined into a
+  single list in the output alist. \var{separator} is the string used
+  to join these elements together; it defaults to a single space, but
+  can usefully be ``\verb|\n|'' (linefeed) or ``\verb|\r\n|''
+  (carriage-return/line-feed).
+  
+  To rejoin a single body list, use scsh's \ex{join-strings}
+  procedure.
+\end{defundesc}
+
+For the following definitions' examples, let's use this set of of
+RFC~822 headers:
+\begin{alltt}
+     From: shivers
+     To: ziggy,
+       newts
+     To: gjs, tk
+\end{alltt}
+%
+
+\begin{defundesc}{get-header-all} {headers name} {string list list}
+  Returns all entries or \sharpf, e.g.\
+  \codex{(get-header-all hdrs 'to)}
+  results to
+  \codex{'((" ziggy," "  newts") (" gjs, tk"))}
+\end{defundesc}
+
+\begin{defundesc}{get-header-lines} {headers name} {string list}
+  Returns all lines of the first entry or \sharpf, e.g.\
+  \codex{(get-header-lines hdrs 'to)}
+  results to
+  \codex{'(" ziggy," "  newts")}
+\end{defundesc}
+
+\begin{defundesc}{get-headers} {headers name \ovar{seperator}} {string}
+  Returns the first entry with the lines joined together by seperator
+  (newline by default), e.g.\
+  \codex{(get-header hdrs 'to)}
+  results to
+\begin{alltt}
+" ziggy,
+  newts"
+\end{alltt}
+%
+  Note, that \ex{newts} is led by two spaces.
+\end{defundesc}
+
+
+\begin{defundesc}{string->symbol-pref}{string}{symbol}
+  Takes a \string and converts it to a symbol using the Scheme
+  implementation's preferred case. (The preferred case is recognized by
+  a doing once a \ex{symbol->string} conversion of \ex{'a}.)
+\end{defundesc}
+
+\section{Desireable functionalities}
+
+\begin{itemize}
+\item Unfolding long lines.
+\item Lexing structured fields.
+\item Unlexing structured fields into canonical form.
+\item Parsing and unparsing dates.
+\item Parsing and unparsing addresses.
+\end{itemize}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: man.tex
+%%% End: 

doc/latex/skeleton.tex

@@ -0,0 +1,8 @@
+\section{Section-Title}
+%
+\begin{description}
+\item[Used files:] 
+\item[Name of the package:] 
+\end{description}
+%
+Not implemented yet.

doc/latex/smtp.tex

@@ -0,0 +1,378 @@
+\chapter{Using SMTP}\label{cha:smtp}
+%
+\begin{description}
+\item[Used files:] smtp.scm
+\item[Name of the package:] smtp 
+\end{description}
+%
+
+\section{Philosophy}
+SMTP protocol procedures tend to return two values:
+\begin{description}
+\item[\semvar{code}] The integer SMTP reply code returned by server for the transaction.
+\item[\semvar{text}] A list of strings -- the text messages tagged by
+  the code.
+\end{description}
+
+The text strings have the initial code numerals and the terminating
+\ex{CR}/\ex{LF}'s stripped. Codes in the range $[1,399]$ are sucess
+codes; codes in the range $[400,599]$ are error codes; codes $>= 600$
+are not part of the official SMTP spec. This module uses codes $>=
+600$ to indicate extra-protocol errors. There are two of these:
+
+\begin{description}
+\item[600 Server reply could not be parsed.]
+   The server sent back some sort of incomprehensible garbage reply.
+\item[621 Premature EOF while reading server reply.]
+   The server shut down in the middle of a reply.
+\end{description}
+
+A list of the official protocol return codes can be seen in table
+\ref{smtp-reply-codes}.
+
+\section{Procedures}
+
+\begin{defundesc}{sendmail}{to-list body \ovar{host}}{code text-list}
+  Mail message \semvar{body} to recipients in list \semvar{to-list}.
+  Message handed off to server running on \semvar{host}; default is
+  the local host.  Returns two values: \semvar{code} and
+  \semvar{text-list}, i.e. the code returned by the server and the
+  text-message, seperated by lines. However, if some recipients were
+  rejected, sendmail sends to the rest of the recipients, and the
+  partial-success return is [700 \semvar{loser-alist}] where
+  \semvar{loser-alist} is a list whose elements are of the form
+  \ex{(\semvar{loser-recipient} \semvar{code} .  \semvar{text})} --
+  that is, for each recipient refused by the server, you get the error
+  data sent back for that guy. The success check is \ex{(< code 400)}.
+\end{defundesc}
+
+\begin{defundesc}{\%sendmail}{from local-host to dest-host
+    message}{code text} Mail \semvar{message} to recipient \semvar{to}
+  using \semvar{dest-host}, telling \semvar{from} as your mail-address
+  and \semvar{local-host} as your system-name.
+\end{defundesc}
+
+
+\defun{expn}{name host}{code text}
+\defunx{vrfy}{name host}{code text}
+\defunx{mail-help}{host \ovar{details}}{code text-list}
+\begin{desc}
+  These three are simple queries of the server as stated in the
+  RFC~821: \ex{expn} asks the server to confirm that the argument
+  identifies a mailing list, and if so, to return the membership of
+  that list. The full name of the users (if known) and the fully
+  specified mailboxes are returned in a multiline reply. \ex{vrfy}
+  asks the receiver to confirm that the argument identifies a user.
+  If it is a user name, the full name of the user (if known) and the
+  fully specified mailbox are returned. \ex{mail-help} causes the
+  server to send helpful information. The command may take an argument
+  (\semvar{details}) (e.g., any command name) and return more specific
+  information as a response.
+\end{desc}
+
+
+\dfn{smtp-transactions}{socket ?transaction1 ...}{code
+  text-list}{syntax}
+\dfnx{smtp-transactions/no-close}{socket ?transaction1 ...}{code
+  text-list}{syntax}
+\begin{desc}
+ These macros make it easy to do simple sequences of SMTP commands.
+
+ Evaluate a series of expressions \semvar{?transaction1},
+ \semvar{?transaction2}, \ldots
+ \begin{itemize}
+ \item Each expression should perform an SMTP transaction, and return
+   two values: \semvar{code} (the integer reply code) and \semvar{text}
+   (list of strings that came with the reply).
+ \item If the transaction's reply code is 221 or 421 (meaning the
+   socket has been closed), then the transaction sequence is is
+   aborted, and the \ex{smtp\=trans\ob{}actions} form returns the
+   \semvar{code} and \semvar{text} values for the current transaction.
+ \item If the reply code is an error code (in the four- or five-hundred
+   range), the transaction sequence is aborted, and the fatal
+   transaction's \semvar{code} and \semvar{text} values are returned.
+   \ex{smtp\=trans\ob{}actions} will additionally close the socket for
+   you; \ex{smtp-trans\ob{}actions/\ob{}no\=close} will not.
+ \item If the transaction is the last in the transaction sequence, its
+   \semvar{code} and \semvar{text} values are returned.
+ \item Otherwise, we throw away the current \semvar{code} and
+   \semvar{text} values, and proceed to the next transaction.
+ \end{itemize}
+ 
+ Since \ex{smtp-trans\ob{}actions} closes the socket whenever it
+ aborts a sequence, an \ex{smtp-trans\ob{}actions} form terminated
+ with an \ex{(smtp/\ob{}quit socket)} transaction will always close
+ the socket.
+
+ If the socket should be kept open in the case of an abort, use
+ \ex{smtp-trans\ob{}actions/\ob{}no\=close}.
+
+ We abort sequences if a transaction results in a 400-class error code.
+ So, a sequence mailing a message to five people, with 5 RCPT's, would
+ abort if the mailing address for one of these people was wrong, rather
+ than proceeding to mail the other four. This may not be what you want;
+ if so, you'll have to roll your own.
+\end{desc}
+
+\defun{smtp/open}{host \ovar{maybe-port}}{socket}
+\defunx{smtp/helo}{local-host-name}{code text-list}
+\defunx{smtp/mail}{sender-address}{code text-list}
+\defunx{smtp/rcpt}{destination-address}{code text-list}
+\defunx{smtp/data}{socket message}{code text-list}
+\defunx{smtp/send}{sender-address}{code text-list}
+\defunx{smtp/soml}{sender-address}{code text-list}
+\defunx{smtp/saml}{sender-address}{code text-list}
+\defunx{smtp/rset}{}{code text-list}
+\defunx{smtp/vrfy}{user}{code text-list}
+\defunx{smtp/expn}{user}{code text-list}
+\defunx{smtp/help}{details}{code text-list}
+\defunx{smtp/noop}{}{code text-list}
+\defunx{smtp/quit}{socket}{code text-list}
+\defunx{smtp/turn}{}{code text-list}
+\begin{desc}
+  These functions implement the basics of the protocol, i.e. they send
+  the corresponding command along with the argument(s), if any. A
+  short look to the code of \ex{\%sendmail} will give you the basics
+  on how to use the commands. You will obtain further informations in
+  the RFC~821. \semvar{host}, \semvar{local-host},
+  \semvar{sender-address}, \semvar{destination-address}, \semvar{user}
+  and \semvar{details} are strings, \semvar{message} may be a string
+  or an input-port. \semvar{socket} is a socket, mostly one returned
+  by \ex{smtp/\ob{}open}.
+\end{desc}
+
+\begin{defundesc}{handle-smtp-reply}{socket}{code text-list}
+  Read and handle the reply. Return an integer (the reply
+  \semvar{code}), and a list of the text lines (\semvar{text-list})
+  that came tagged by the reply code.  The text lines have the
+  reply-code prefix (first 4 chars) and the terminating cr/lf's
+  stripped.
+\end{defundesc}
+
+\begin{defundesc}{read-smtp-reply}{port}{code text-list}
+ Read a reply from the SMTP server. Returns two values:
+ \begin{description}
+ \item[\semvar{code}] Integer. The reply code.
+ \item[\semvar{text}] String list. A list of the text lines comprising
+     the reply.  Each line of text is stripped of the initial
+     reply-code numerals (e.g., the first four chars of the reply),
+     and the trailing cr/lf. We are in fact generous about what we
+     take to be a line -- the protocol requires cr/lf terminators, but
+     we'll accept just lf. This appears to true to the spirit of the
+     "be strict in what you send, and generous in what you accept"
+     Internet protocol philosphy.
+   \end{description}
+\end{defundesc}
+
+\begin{defundesc}{parse-smtp-reply}{line}{code rest more?}
+ Parse a line of SMTP reply. Return three values:
+ \begin{description}
+ \item[\semvar{code}] integer -- the reply code that prefixes the
+   string.
+ \item[\semvar{rest}] string -- the rest of the line.
+ \item[\semvar{more?}] boolean -- is there more reply to read (i.e.,
+   was the numeric reply code terminated by a ``\ex{-}'' character?)
+ \end{description}
+\end{defundesc}
+
+\begin{defundesc}{smtp-stuff}{text pchar}{stuffed-string last-char}
+  The message body of a piece of email is terminated by the sequence
+  \ex{<CRLF> <period> <CRLF>}, i.e. end-of-line, period,
+  end-of-line.  If the message body contains this magic sequence, it
+  has to be escaped.  We do this by mapping the sequence \ex{<LF>
+    <period>} to \ex{<lf> <period> <period>}; the SMTP receiver undoes
+  this mapping.
+  
+  \semvar{text} is a string to stuff, \semvar{pchar} was the character
+  read just before \semvar{text} (which matters if it is a line-feed).
+  If \semvar{text} is the first chunk of the entire msg, then
+  \semvar{pchar} can be \sharpf. Return two values: the
+  \semvar{stuffed-string}, and the last char in \semvar{text} (or
+  \semvar{pchar} if \semvar{text} is empty). The last-char value
+  returned can be used as the \semvar{pchar} arg for the following
+  call to \ex{smtp\=stuff}.
+\end{defundesc}
+
+\section{Additional information about SMTP}
+
+\section{Reply codes}
+
+This material is taken from the RFC. The first digits encode categories
+of responses:
+\begin{description}
+\item[1yz Positive Preliminary reply\,] The command has been
+  accepted, but the requested action is being held in abeyance,
+  pending confirmation of the information in this reply.  The
+  sender-SMTP should send another command specifying whether to
+  continue or abort the action.
+\begin{leftinset}
+  Note: SMTP does not have any commands that allow this type of reply,
+  and so does not have the continue or abort commands.
+\end{leftinset}
+\item[2yz  Positive Completion reply\,] The requested action has
+  been successfully completed.  A new request may be initiated.
+\item[3yz  Positive Intermediate reply\,] The command has been
+  accepted, but the requested action is being held in abeyance,
+  pending receipt of further information.  The sender-SMTP should send
+  another command specifying this information.  This reply is used in
+  command sequence groups.
+\item[4yz  Transient Negative Completion reply\,] The command was
+  not accepted and the requested action did not occur.  However, the
+  error condition is temporary and the action may be requested again.
+  The sender should return to the beginning of the command sequence
+  (if any).  It is difficult to assign a meaning to ``transient'' when
+  two different sites (receiver- and sender- SMTPs) must agree on the
+  interpretation.  Each reply in this category might have a different
+  time value, but the sender-SMTP is encouraged to try again.  A rule
+  of thumb to determine if a reply fits into the 4yz or the 5yz
+  category (see below) is that replies are 4yz if they can be repeated
+  without any change in command form or in properties of the sender or
+  receiver.  (E.g., the command is repeated identically and the
+  receiver does not put up a new implementation.)
+\item[5yz  Permanent Negative Completion reply\,] The command was
+  not accepted and the requested action did not occur.  The
+  sender-SMTP is discouraged from repeating the exact request (in the
+  same sequence).  Even some ``permanent'' error conditions can be
+  corrected, so the human user may want to direct the sender-SMTP to
+  reinitiate the command sequence by direct action at some point in
+  the future (e.g., after the spelling has been changed, or the user
+  has altered the account status).
+\end{description}
+
+The second digit encodes responses in specific categories:
+\begin{description}
+\item[x0z  Syntax\,] These replies refer to syntax errors,
+  syntactically correct commands that don't fit any functional
+  category, and unimplemented or superfluous commands.
+\item[x1z  Information\,] These are replies to requests for
+  information, such as status or help.
+\item[x2z  Connections\,] These are replies referring to the
+  transmission channel.
+\item[x3z\,] Unspecified as yet.
+\item[x4z\,] Unspecified as yet.
+\item[x5z Mail system\,] These replies indicate the status of the
+  receiver mail system vis-a-vis the requested transfer or other mail
+  system action.
+\end{description}
+
+\begin{table}
+\begin{center}
+\label{smtp-reply-codes}
+\begin{tabular}{|lp{10cm}|}
+\hline
+ 500 & Syntax error, command unrecognized \newline
+ [This may include errors such as ``command line too long''] \\
+ 501 & Syntax error in parameters or arguments \\
+ 502 & Command not implemented\\
+ 503 & Bad sequence of commands\\
+ 504 & Command parameter not implemented\\
+\hline
+ 211 & System status, or system help reply\\
+ 214 & Help message \newline
+    [Information on how to use the receiver or the meaning of a
+    particular non-standard command; this reply is useful only
+    to the human user]\\
+\hline
+ 220 & \semvar{domain} Service ready \\
+ 221 & \semvar{domain} Service closing transmission channel\\
+ 421 & \semvar{domain} Service not available,
+     closing transmission channel\newline
+    [This may be a reply to any command if the service knows it
+    must shut down]\\
+\hline  
+ 250 & Requested mail action okay, completed\\
+ 251 & User not local; will forward to \semvar{forward-path}\\
+ 450 & Requested mail action not taken: mailbox unavailable
+    [E.g., mailbox busy]\\
+ 550 & Requested action not taken: mailbox unavailable
+    [E.g., mailbox not found, no access]\\
+ 451 & Requested action aborted: error in processing\\
+ 551 & User not local; please try \semvar{forward-path}\\
+ 452 & Requested action not taken: insufficient system storage\\
+ 552 & Requested mail action aborted: exceeded storage allocation\\
+ 553 & Requested action not taken: mailbox name not allowed
+    [E.g., mailbox syntax incorrect]\\
+ 354 & Start mail input; end with \ex{CRLF}.\ex{CRLF}\\
+ 554 & Transaction failed\\
+\hline
+\end{tabular}
+\caption{Complete list of SMTP reply-codes.}
+\end{center}
+\end{table}
+
+\begin{table}
+\begin{center}
+\label{smtp-command-reply-codes}
+\begin{tabular}{|l||l|l|l|l|}
+\hline
+\bf{What} & \bf{intermediate} & \bf{success} & \bf{failure} & \bf{error}\\
+\hline
+\hline
+conn. establ. & &
+      220 &
+      421 &\\
+  HELO & &
+      250 & &
+      500, 501, 504, 421\\
+  MAIL & &
+      250 &
+      552, 451, 452 &
+      500, 501, 421\\
+  RCPT & &
+      250, 251 &
+      550, 551, 552, 553, 450, 451, 452 &
+      500, 501, 503, 421\\
+  DATA &
+      354 \verb|->| data &
+      250 &
+      552, 554, 451, 452 & \\ & otherwise & &
+      451, 554 &
+      500, 501, 503, 421\\
+  RSET & &
+      250 & &
+      500, 501, 504, 421\\
+  SEND & & 
+      250 & 
+      552, 451, 452 & 
+      500, 501, 502, 421\\
+  SOML & & 
+      250 & 
+      552, 451, 452 & 
+      500, 501, 502, 421\\
+  SAML & & 
+      250 & 
+      552, 451, 452 & 
+      500, 501, 502, 421\\
+  VRFY & &
+      250, 251 & 
+      550, 551, 553 &
+      500, 501, 502, 504, 421\\
+  EXPN & & 
+      250 & 
+      550 & 
+      500, 501, 502, 504, 421\\
+  HELP & & 
+      211, 214 & &
+      500, 501, 502, 504, 421\\
+  NOOP & &
+      250 & &
+      500, 421\\
+  QUIT & &
+      221 & &
+      500\\
+  TURN & &
+      250 &
+      502 &
+      500, 503\\
+\hline
+\end{tabular}
+\caption{command--reply sequences.}
+\end{center}
+\end{table}
+
+
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 

doc/latex/toothless.tex

@@ -0,0 +1,57 @@
+\chapter{Evaluating expression in ``safe'' environments}
+%
+\begin{description}
+\item[Used files:] none, defined in modules.scm
+\item[Name of the package:] loser, toothless, toothless-eval \\
+  (you want the last one)
+\end{description}
+%
+
+\section{Overview}
+\FIXME{Is toothless really R5RS, too?}
+These modules define an environment that is \RnRS without features that
+could examine or effect the file system. You can also use it as a
+model of how to execute code in other protected environments in \scm.
+
+\section{The \protect{\texttt{loser}} package}
+The \ex{loser} package exports only one procedure:
+
+\begin{defundesc}{loser}{name}{nothing}
+  Raises an error like ``Illegal call \var{name}''.
+\end{defundesc}
+
+\section{The \protect{\texttt{toothless}} package}
+The \ex{toothless} package contains everything of \RnRS except
+that following procedure cause an error if called:
+\begin{itemize}
+\item \ex{call-with-input-file}
+\item \ex{call-with-output-file}
+\item \ex{load}
+\item \ex{open-input-file}
+\item \ex{open-output-file}
+\item \ex{transcript-on}
+\item \ex{with-input-from-file}
+\item \ex{with-input-to-file}
+\item \ex{eval}
+\item \ex{interaction-environment}
+\item \ex{scheme-report-environment}
+\end{itemize}
+
+So, \ex{toothless} creates an environment as described in
+\emph{Overview} above.
+
+\section{The \protect{\texttt{toothless-eval}} package}
+
+\begin{defundesc}{eval-safely} {expression} {any result}
+  Creates a brand new package, imports the \ex{toothless} structure,
+  and evaluates \semvar{expression} in it. When the evaluation is
+  done, the environment is thrown away, so \semvar{expression}'s
+  side-effects don't persist from one \ex{eval\=safely} call to the
+  next. If \semvar{expression} raises an error exception, we abort and
+  return \sharpf.
+\end{defundesc}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 

doc/latex/uri.tex

@@ -0,0 +1,227 @@
+\chapter{Handle URIs}\label{cha:uri}
+%
+\begin{description}
+\item[Used files:] uri.scm
+\item[Name of the package:] uri 
+\end{description}
+%
+
+\section{Overview}
+A URI (Uniform Resource Identifier) is of following syntax:
+\begin{inset}
+\ovar{scheme\/} : \semvar{path} \ovar{{\normalfont?\/} search} \ovar{{\normalfont\#} fragmentid}
+\end{inset}
+Parts in brackets may be ommitted. The last part is usually referred
+to as fragid in this document.
+
+As you see, the URI contains characters like \verb|:| to indicate its
+different parts. But what, if the \semvar{scheme} contains \verb|:| as
+part of its name? For this purpose, 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|\%hh| where \verb|h| is a hexadecimal digit. The hexadecimal
+number refers to the (US) ASCII code of the escaped character, e.g.\ 
+\ex{\%20} is space (ASCII character 32) and \ex{\%61} is `a' (ASCII
+character 97). This module provides procedures to escape and unescape
+strings that are meant to be used in a URI.
+
+\section{Procedures}
+
+\begin{defundesc}{parse-uri} {uri-string } {scheme path search
+    frag-id} \label{proc:parse-uri}
+  
+  Parses an \semvar{uri\=string} in the possible four fields, as
+  mentioned above in \emph{Overview}. These four fields are returned
+  as a multiple value. They are \emph{not} unescaped, as the rules for
+  parsing the \semvar{path} component in particular need unescaped
+  text, and are dependent on \semvar{scheme}. The URL parser is
+  responsible for doing this. If the \semvar{scheme}, \semvar{search}\ 
+  or \semvar{fragid} portions are not specified, they are \sharpf.
+  Otherwise, \semvar{scheme}, \semvar{search}, and \semvar{fragid} are
+  strings. \semvar{path} is a non-empty string list -- the path split
+  at slashes.
+  
+  For those of you who are interested, here is a description of the
+  parsing technique. It is inwards from both ends.
+  \begin{itemize}
+  \item First we search forwards for the first reserved character
+    (\verb|=|, \verb|;|, \verb|/|, \verb|#|, \verb|?|, \verb|:| or
+    \verb|space|). If it's a colon, then that's the \semvar{scheme}
+    part, otherwise we have no \semvar{scheme} part. At all events we
+    remove it.
+  \item Then we search backwards from the end for the last reserved
+    char.  If it's a sharp, then that's the \semvar{fragid} part --
+    remove it.
+  \item Then we search backwards from the end for the last reserved
+    char.  If it's a question-mark, then that's the \semvar{search}
+    part -- remove it.
+  \item What's left is the path. We split 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 is not absolutely conform
+    with 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.
+\end{defundesc}
+
+\begin{defundesc}{unescape-uri} {string \ovar{start \ovar{end}}} {string}
+  Unescapes a string. This procedure should only be used \emph{after}
+  the URL (!) was parsed, since unescaping may introduce characters
+  that blow up the parse (that's why escape sequences are used in URIs
+  ;-). Escape sequences are of the scheme as described in ``Overview''.
+\end{defundesc}
+
+
+%\texttt{uri-escaped-chars} \hfill
+%\texttt{char-set}\index{\texttt{uri-escaped-chars}}
+\defvar{uri-escaped-chars}{char-set}
+\begin{desc}
+  A set of characters that are escaped in URIs. These are the
+  following characters: dollar (\verb|$|), minus (\verb|-|),%fool Xemacs$
+  underscore (\verb|_|), at (\verb|@|), dot (\verb|.|), and-sign
+  (\verb|&|), exclamation mark (\verb|!|), asterisk (\verb|*|),
+  backslash (\verb|\|), double quote (\verb|"|), single quote
+  (\verb|'|), open brace (\verb|(|), close brace (\verb|)|), comma
+  (\verb|,|) plus (\verb|+|) and all other characters that are neither
+  letters nor digits (such as space and control characters).
+\end{desc}
+
+\begin{defundesc}{escape-uri} {string \ovar{escaped-chars}} {string}
+  Escapes characters of \semvar{string} that are given with
+  \semvar{escaped\=chars}. \semvar{escaped\=chars} default to
+  \ex{uri\=escaped\=chars}. 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
+  ``\ex{//lcs.\ob{}mit.\ob{}edu:8001\ob/foo\ob/bar.html}'' because the
+  sla\-shes and co\-lons would be escaped. Note that \ex{esacpe-uri}
+  doesn't check this as it would lose his meaning.
+\end{defundesc}
+
+\begin{defundesc}{resolve-uri} {cscheme cp scheme p} {scheme path}
+\FIXME{Sorry, I can't figure out what resolve-uri is inteded to do.
+Perhaps I find it out later.}
+
+  Nobody really knows what this procedure was intended to do.
+
+  The code seems to have a bug: In the body of receive, there's a
+  loop. j should, according to the comment, count sequential \verb|/|.
+  But \ex{j} counts nothing in the body. Either zero is added \ex{((lp
+    (cdr cp-tail) (cons (car cp-tail) rhead) (+ j 0)))} or \ex{j} is
+  set to 1 \ex{((lp (cdr cp-tail) (cons (car cp-tail) rhead) 1))}.
+  Nevertheless, \ex{j} is expected to reach value \ex{numsl} that can
+  be larger than one. So what?  I am confused.
+\end{defundesc}
+
+\begin{defundesc}{split-uri-path} {uri start end} {list}
+  Splits uri at slashes. Only the substring given with \semvar{start}
+  (inclusive) and \semvar{end} (exclusive) as indices is considered.
+  \semvar{start} and $\semvar{end} - 1$ have to be within the range of
+  \semvar{uri}.  Otherwise an index-out-of-range exception will be
+  raised. Example: \codex{(split-uri-path "foo/bar/colon" 4 11)}
+  results to \codex{'("bar" "col")}
+\end{defundesc}
+
+\begin{defundesc}{uri-path-list->path} {plist} {string}
+  Generates a path out of an uri-path-list by inserting slashes
+  between the elements of \semvar{plist}. If you want to use the
+  resulting string for further operation, you should escape the
+  elements of \semvar{plist} in case the contain slashes. This doesn't
+  escape them for you, you must do that yourself like
+  \ex{(uri-path-list->path (map escape-uri pathlist))}.
+\end{defundesc}
+
+\begin{defundesc}{simplify-uri-path} {path} {list}
+  Removes `\ex{.}' and `\ex{..}' entries from path. The result is
+  a (maybe empty) list representing a path that does not contain any
+  `\ex{.}' or `\ex{..}'\,. The list can only be empty if the path
+  did not start with a slash (for the rare occasion someone wants to
+  simplify a relative path). The result is \sharpf{} if the path tries
+  to back up past root, for example by `\ex{/..}' or
+  `\ex{/foo\ob/..\ob/..}' or just `\ex{..}'\,. `\ex{//}' may occur
+  somewhere in the path referring to root but not being backed up.
+  Examples: 
+%FIXME: Can't we have a better environment for examples like these?
+\begin{alltt}
+(simplify-uri-path
+ (split-uri-path  "/foo/bar/baz/.."  0 15))
+\end{alltt} 
+  results to 
+  \codex{'("" "foo" "bar")}
+
+\begin{alltt}
+(simplify-uri-path 
+ (split-uri-path "foo/bar/baz/../../.." 0 20))
+\end{alltt}
+  results to
+  \codex{'()}
+
+\begin{alltt}
+(simplify-uri-path 
+ (split-uri-path "/foo/../.." 0 10))
+\end{alltt}
+  results to
+  \codex{\sharpf          ; tried to back up root}
+
+\begin{alltt}
+(simplify-uri-path 
+ (split-uri-path "foo/bar//" 0 9))
+\end{alltt}
+  results to
+  \codex{'("")       ; "//" refers to root}
+
+\begin{alltt}
+(simplify-uri-path 
+ (split-uri-path "foo/bar/" 0 8))
+\end{alltt}
+  results to 
+  \codex{'("")       ; last "/" also refers to root}
+
+\begin{alltt}
+(simplify-uri-path 
+ (split-uri-path "/foo/bar//baz/../.." 0 19))
+\end{alltt}
+  results to
+  \codex{\sharpf          ; tries to back up root}
+\end{defundesc}
+
+\section{Unexported names}
+
+\defvar{uri-reserved}{char-set}
+\begin{desc}
+  A list of reserved characters (semicolon, slash, hash, question
+  mark, double colon and space).
+\end{desc}
+
+\begin{defundesc}{hex-digit?} {character} {boolean}
+  Returns \sharpt{} if character is a hexadecimal digit (i.e., one of 1--9,
+  a--f, A--F), \sharpf{} otherwise.
+\end{defundesc}
+
+
+\begin{defundesc}{hexchar->int} {character} {number}
+  Translates the given character to an integer, e.g. \ex{(hexchar->int
+  \#a)} results to 10.
+\end{defundesc}
+
+\begin{defundesc}{int->hexchar} {integer} {character}
+  Translates the given integer from range 1--15 into an hexadecimal
+  character (uses uppercase letters), e.g. \ex{(int->hexchar 14)}
+  results to `E'.
+\end{defundesc}
+
+\begin{defundesc}{rev-append} {list-a list-b} {list}
+  Performs a \ex{(append (reverse list-a) list-b)}. The comment says it
+  should be defined in a list package but I am wondering how often
+  this will be used.
+\end{defundesc}
+
+%EOF
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: "man"
+%%% End: 

doc/latex/url.tex

@@ -0,0 +1,132 @@
+\chapter{URL}\label{cha:url}
+%
+\begin{description}
+\item[Used files:] url.scm
+\item[Name of the package:] url
+\end{description}
+%
+\section{Overview}
+This modules contains procedures to parse and unparse URLs. Till now,
+only the parsing of http URLs is implemented.
+
+\section{Entry points}
+\defun{make-userhost}{user password host port}{userhost-record}
+\defunx{userhost?}{thing}{boolean}
+\defunx{userhost:user}{userhost-record}{value}
+\defunx{userhost:password}{userhost-record}{value}
+\defunx{userhost:host}{userhost-record}{value}
+\defunx{userhost:port}{userhost-record}{value}
+\defunx{set-userhost:user}{userhost-record new-value}{void}
+\defunx{set-userhost:password}{userhost-record new-value}{void}
+\defunx{set-userhost:host}{userhost-record new-value}{void}
+\defunx{set-userhost:port}{userhost-record new-value}{void}
+\begin{desc}
+  \ex{make\=userhost} creates a new \ex{userhost} record. This record
+  describes path-prefixes of the form
+  \semvar{user}:\semvar{password}@\semvar{host}:\semvar{port}. These
+  are frequently used as the initial prefix of URL's describing
+  Internet resources. Each slot is a decoded string or \sharpf\ (yes,
+  \semvar{port} is also a string).
+  
+  \ex{userhost?} is the corresponding predicate,
+  \ex{userhost:\ob{}user}, \ex{userhost:\ob{}pass\ob{}word},
+  \ex{userhost:\ob{}host} and \ex{userhost:\ob{}port} are the
+  correspondig selectors and \ex{set\=userhost:\ob{}user},
+  \ex{set\=userhost:\ob{}pass\ob{}word}, \ex{set\=userhost:\ob{}host}
+  and \ex{set\=userhost:\ob{}port} the corresponding mutators. As you
+  can store everything into the record fields, the selectors may
+  return any type of value. However, under normal circumstances, only
+  \str\ or \sharpf\ is returned.
+\end{desc}
+
+\defun{parse-userhost}{path default}{userhost-record}
+\begin{defundescx}{userhost->string}{userhost-record}{string}
+  \ex{parse\=userhost} parses a URI \semvar{path} (a list representing
+  a path, not a string!) into a userhost record. Default values are
+  taken from the userhost record \semvar{default} except for the
+  host. The values are unescaped and stored into a userhost 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{userhost->string} just does the inverse job: it unparses
+  \semvar{userhost-record} into a string. The elements of the record
+  are escaped before the are put together.  
+
+  Example:
+\begin{alltt}
+> (define default 
+    (make-userhost 
+     "andreas"  "se ret" "www.sf.net" "80"))
+> (userhost->string default)
+"andreas:se\%20ret@www.sf.net:80"
+> (parse-userhost 
+   '("" "" "foo\%20bar@www.scsh.net" "docu" "index.html") 
+   default)
+'#{userhost}
+> (userhost->string ##)
+"foo\%20bar:se\%20ret@www.scsh.net:80"
+\end{alltt}
+
+  For details about escaping and unescaping see Chapter ``Handle
+  URIs'' at page \pageref{cha:uri}.
+\end{defundescx}
+
+
+\defun{make-http-url}{userhost path search frag-id}{http-url-record}
+\defunx{http-url?}{thing}{boolean}
+\defunx{http-url:userhost}{http-url}{value}
+\defunx{http-url:path}{http-url}{value}
+\defunx{http-url:search}{http-url}{value}
+\defunx{http-url:frag-id}{http-url}{value}
+\defunx{set-http-url:userhost}{http-url new-value}{void}
+\defunx{set-http-url:path}{http-url new-value}{void}
+\defunx{set-http-url:search}{http-url new-value}{void}
+\defunx{set-http-url:frag-id}{http-url new-value}{void}
+\begin{desc}
+  \ex{make\=http\=url} creates a new \ex{httpd\=url} record.
+  \semvar{userhost} is a record, containing the initial part of the
+  address (like
+  \ex{ano\ob{}ny\ob{}mous@\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu:\ob{}80}).
+  \semvar{path} contains the URL's path split at slashes, e.g.\ 
+  \ex{"foo/\ob{}bar/\ob{}baz/"} becomes \ex{'("foo" "bar" "baz" "")}.
+  These elements are in raw, unescaped format. To convert them back to
+  a string, use \ex{(uri\=path\=list->path (map escape\=uri
+    pathlist))}. \semvar{search} and \semvar{frag\=id} are the last
+  two parts of the URL (see Chapter \ref{cha:uri} on page
+  \pageref{cha:uri} about parts of an URI).
+  
+  \ex{http\=url:userhost}, \ex{http\=url:path}, \ex{http\=url:search}
+  and \ex{http\=url:frag\=id} are the corresponding selectors,
+  \ex{set\=http\=url:userhost}, \ex{set\=http\=url:path},
+  \ex{set\=http\=url:search} and \ex{set\=http\=url:frag\=id} the
+  corresponding mutators. As you can store every type of value into
+  the record fields, the selectors can return any type of value.
+  However, \ex{http\=:userhost} usually returns a \ex{userhost}
+  record, \ex{http\=:path} returns a list of \str{}s and
+  \ex{http\=url:search} and \ex{http\=url:frag\=id} return both
+  \str{}s.
+\end{desc}
+
+\defun{parse-http-url}{path search frag-id}{http-url-record}
+\begin{defundescx}{http-url->string}{http-url-record}{string}
+  The URI parser (\ex{parse\=uri} in \ex{uri.\ob{}scm}) maps a string
+  to four parts: \semvar{scheme}, \semvar{path}, \semvar{search} and
+  \semvar{frag-id} (see section \ref{proc:parse-uri} at page
+  \pageref{proc:parse-uri} for details). If \semvar{scheme} is
+  ``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.
+  \semvar{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.
+
+  \ex{http-url->string} just does the inverse job. It converts a
+  \ex{http\=url} record into a \str.
+\end{defundescx}
+
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: "man"
+%%% End: 

httpd-core.scm

@@ -1,480 +0,0 @@
-;;; http server in the Scheme Shell	-*- Scheme -*-
-;;; Olin Shivers <shivers@lcs.mit.edu>
-
-;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
-
-;;; Problems:
-;;; Need to html-quote URI's when printing them out to HTML text.
-
-;;; This file implements the core of an HTTP server: code to establish
-;;; net connections, read and parse requests, and handler errors. 
-;;; It does not have the code to actually handle requests. That's up
-;;; to other modules, and could vary from server to server. To build
-;;; a complete server, you need to define path handlers (see below) --
-;;; they determine how requests are to be handled.
-;;;
-;;; A draft document detailing the HTTP 1.0 protocol can be found at
-;;; http://www.w3.org/hypertext/WWW/Protocols/HTTP1.0/
-;;;      draft-ietf-http-spec.html
-
-;;; Imports and non-R4RS'isms
-;;;	\r \n in strings for cr and lf.
-;;;	let-optionals				(let-opt)
-;;;	receive values				(MV return)
-;;;	scsh system calls
-;;; 	rfc822 header parsing
-;;;	crlf-io					(read cr/lf terminated lines)
-;;;	when, unless, switch, ?			(conditionals)
-;;;	uri, url packages
-;;; 	defrec package				(record structures)
-;;;	defenum					(enumerated types)
-;;;	ignore-errors				(HANDLE package)
-;;;     string hacking stuff
-;;;	char-set stuff
-;;;     format					(Formatted output)
-;;;	httpd error stuff
-;;;	condition-stuff				(S48 error conditions)
-
-;;; Constants
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define server/version  "Scheme-Underground/1.0")
-(define server/protocol "HTTP/1.0")
-
-;;; Configurable Variables
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Address for config error reports
-(define server/admin "sperber@informatik.uni-tuebingen.de")
-(define (set-server/admin! s)
-  (set! server/admin s))
-
-
-(define *http-log?* #t)
-(define *http-log-port* (error-output-port))
-(define (http-log fmt . args)
-  (? (*http-log?*
-      (apply format *http-log-port* fmt args)
-      (force-output *http-log-port*))))
-
-
-;;; (httpd path-handler [port server-root-dir])
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; The server top-level. PATH-HANDLER is the top-level request path handler --
-;;; the procedure that actually deals with the request. PORT defaults to 80.
-;;; SERVER-ROOT-DIR is the server's working directory; it defaults to
-;;;     /usr/local/etc/httpd
-
-(define (httpd path-handler . args)
-  (let-optionals args ((port 80)
-		       (root-dir "/usr/local/etc/httpd"))
-    (with-cwd root-dir
-      (bind-listen-accept-loop protocol-family/internet
-				       
-	;; Why is the output socket unbuffered? So that if the client
-	;; closes the connection, we won't lose when we try to close the
-	;; socket by trying to flush the output buffer.
-        (lambda (sock addr) ; Called once for every connection.
-	  (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
-
-	  (fork (lambda ()	; Kill this line to bag forking.
-		  (let* ((i (dup->inport  (socket:inport  sock) 0))
-			 (o (dup->outport (socket:outport sock) 1)))
-		    (set-port-buffering i bufpol/none) ; Should propagate. ecch.
-		    (with-current-input-port i		    ; bind the
-		      (with-current-output-port o	    ; stdio ports, &
-			(process-toplevel-request path-handler sock))) ; do it.
-		    (close-input-port i)	; Really only necessary
-		    (close-output-port o))))	; for non-forking variant.
-
-	  (reap-zombies) 	; Clean up: reap dead children,
-	  (close-socket sock))	;     and close socket.
-
-	port))))
-
-;;; Top-level http request processor
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Read, parse, and handle a single http request. The only thing that makes
-;;; this complicated is handling errors -- as a server, we can't just let the
-;;; standard error handlers toss us into a breakpoint. We have to catch the
-;;; error, send an error reply back to the client if we can, and then keep
-;;; on trucking. This means using the S48's condition system to catch and
-;;; handle the various errors, which introduces a major point of R4RS
-;;; incompatibiliy -- R4RS has no exception system. So if you were to port
-;;; this code to some other Scheme, you'd really have to sit down and think
-;;; about this issue for a minute.
-
-(define (process-toplevel-request handler sock)
-  ;; This top-level error-handler catches *all* uncaught errors and warnings.
-  ;; If the error condition is a reportable HTTP error, we send a reply back 
-  ;; to the client. In any event, we abort the transaction, and return from
-  ;; PROCESS-TOPLEVEL-REQUEST.
-  ;;
-  ;; We *oughta* map non-http-errors into replies anyway.
-  (with-fatal-error-handler (lambda (c decline)		; No call to decline
-			      (http-log "Error! ~s~%" c)
-			      (if (http-error? c)	; -- we handle all.
-				  (apply send-http-error-reply
-					 (condition-stuff c))))
-
-    (let ((req (with-fatal-error-handler	; Map syntax errors
-	           (lambda (c decline)		; to http errors.
-		     (if (fatal-syntax-error? c)
-			 (apply http-error http-reply/bad-request
-				#f	; No request yet.	
-				"Request parsing error -- report to client maintainer."
-				(condition-stuff c))
-			 (decline)))			   ; Actual work:
-		 (parse-http-request sock))))		   ; (1) Parse request.
-      (handler (http-url:path (request:url req)) req))))   ; (2) Deal with it.
-
-
-;;;; HTTP request parsing
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; This code defines the http REQUEST data structure, and provides
-;;;; code to read requests from an input port.
-
-(define-record request
-  method		; A string such as "GET", "PUT", etc.
-  uri			; The escaped URI string as read from request line.
-  url			; An http URL record (see url.scm).
-  version		; A (major . minor) integer pair.
-  headers		; An rfc822 header alist (see rfc822.scm).
-  socket)		; The socket connected to the client.
-
-;;; A http protocol version is an integer  pair: (major . minor).
-
-(define (version< v1 v2)
-  (or (< (car v1) (car v2))
-      (and (= (car v1) (car v2))
-	   (< (cdr v1) (cdr v2)))))
-
-(define (version<= v1 v2) (not (version< v2 v1)))
-
-(define (v0.9-request? req)
-  (version<= (request:version req) '(0 . 9)))
-
-
-(define (version->string v)
-  (string-append "HTTP/"
-		 (number->string (car v))
-		 "."
-		 (number->string (cdr v))))
-
-
-;;; 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)
-  (let ((line (read-crlf-line)))
-
-    ;; Blat out some logging info.
-    
-    (if *http-log?*
-	(let* ((addr (socket-remote-address sock))
-	       (host (host-info:name (host-info addr))))
-	  (http-log "~a: ~a~%" host line)))
-
-    (if (eof-object? line)
-	(fatal-syntax-error "EOF while parsing request.")
-
-	(let* ((elts (string->words line))	; Split at white-space.
-	       (version (switch = (length elts)
-			  ((2) '(0 . 9))
-			  ((3) (parse-http-version (caddr elts)))
-			  (else (fatal-syntax-error "Bad HTTP version.")))))
-
-	  (let* ((meth (car elts))
-		 (uri-string (cadr elts))
-		 (url (parse-http-servers-url-fragment uri-string sock))
-		 (headers (if (equal? version '(0 . 9)) '()
-			      (read-rfc822-headers))))
-	    (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 sleazier but faster if we just
-;;; computed the default host and port at server-startup time, instead of
-;;; on every request.
-
-(define (parse-http-servers-url-fragment uri-string socket)
-  (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 userhost struct from our net connection.
-	    (if (and (pair? path) (string=? (car path) ""))
-		(let* ((addr (socket-local-address socket))
-		       (local-name (my-fqdn addr))
-		       (portnum (my-port addr)))
-		  (make-http-url (make-userhost #f #f
-						local-name
-						(number->string portnum))
-				 (map unescape-uri (cdr path)) ;Skip initial /.
-				 search
-				 #f))
-
-		(fatal-syntax-error "Path fragment must begin with slash"
-				    uri-string))))))
-
-
-(define parse-http-version
-  (let ((re (make-regexp "^HTTP/([0-9]+)\\.([0-9]+)$"))
-	(lose (lambda (s) (fatal-syntax-error "Bad HTTP version" s))))
-    (lambda (vstring)
-      (let ((m (regexp-exec re vstring)))
-	(if m
-	    (cons (or (string->number (match:substring m 1) 10) (lose vstring))
-		  (or (string->number (match:substring m 2) 10) (lose vstring)))
-	    (lose vstring))))))
-				      
-
-;;; Split string into a list of whitespace-separated strings.
-;;; This could have been trivially defined in scsh as (field-splitter " \t\n")
-;;; but I hand-coded it because it's short, and I didn't want invoke the
-;;; regexp machinery for something so simple.
-
-(define non-whitespace (char-set-invert char-set:whitespace))
-
-(define (string->words s)
-  (let recur ((start 0))
-    (? ((char-set-index s non-whitespace start) =>
-        (lambda (start)
-	  (? ((char-set-index s char-set:whitespace start) => 
-	      (lambda (end)
-		(cons (substring s start end)
-		      (recur end))))
-	     (else (list (substring s start (string-length s)))))))
-       (else '()))))
-
-
-;;;; Sending replies
-;;;;;;;;;;;;;;;;;;;;
-
-;;; Reply codes
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; (define http-reply/ok 200), etc.
-;;; Also, build an alist HTTP-REPLY-TEXT-TABLE mapping integer reply codes
-;;; to their diagnostic text messages.
-
-(define-syntax define-http-reply-codes
-  (syntax-rules ()
-    ((define-http-reply-codes table set (name val msg) ...)
-     (begin (define table '((val . msg) ...))
-	    (define-enum-constant set name val)
-	    ...))))
-
-(define-http-reply-codes http-reply-text-table http-reply
-  (ok			200 "OK")
-  (created		201 "Created")
-  (accepted		202 "Accepted")
-  (prov-info		203 "Provisional Information")
-  (no-content		204 "No Content")
-
-  (mult-choice		300 "Multiple Choices")
-  (moved-perm		301 "Moved Permanently")
-  (moved-temp		302 "Moved Temporarily")
-  (method		303 "Method (obsolete)")
-  (not-mod		304 "Not Modified")
-
-  (bad-request		400 "Bad Request")
-  (unauthorized		401 "Unauthorized")
-  (payment-req		402 "Payment Required")
-  (forbidden		403 "Forbidden")
-  (not-found		404 "Not Found")
-  (method-not-allowed	405 "Method Not Allowed")
-  (none-acceptable	406 "None Acceptable")
-  (proxy-auth-required	407 "Proxy Authentication Required")
-  (timeout		408 "Request Timeout")
-  (conflict		409 "Conflict")
-  (gone			410 "Gone")
-
-  (internal-error	500 "Internal Server Error")
-  (not-implemented	501 "Not Implemented")
-  (bad-gateway		502 "Bad Gateway")
-  (service-unavailable	503 "Service Unavailable")
-  (gateway-timeout	504 "Gateway Timeout"))
-	
-(define (reply-code->text code)
-  (cdr (assv code http-reply-text-table)))
-
-
-;;; Text generation utilities.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
-
-(define (time->http-date-string time)
-  (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
-
-;;; Output the first chunk of a reply header.
-
-(define (begin-http-header out reply-code)
-  (format out "~A ~d ~A\r~%"
-	  server/protocol reply-code (reply-code->text reply-code))
-  (format out "Date: ~A\r~%" (time->http-date-string (time)))
-  (format out "Server: ~A\r~%" server/version))
-
-(define (title-html out message new-protocol?)
-  (if new-protocol? (write-crlf out))	; Separate html from headers.
-  (format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
-  (format out "<BODY>~%<H1>~A</H1>~%" message))
-
-
-;;; (send-http-error-reply reply-code req [message . extras])
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Take an http-error condition, and format it into a reply to the client.
-;;;
-;;; 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, and we make minimal assumptions in this 
-;;; case (0.9 protocol for the reply, for example). I might be better off
-;;; writing a special-case procedure for that case...
-
-;;; SEND-HTTP-ERROR-REPLY is called from error handlers, so to avoid
-;;; infinite looping, if an error occurs while it is running, we just
-;;; silently return. (We no longer need to do this; I have changed 
-;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll
-;;; leave it in to play it safe.)
-
-(define (send-http-error-reply reply-code req . args)
-  (ignore-errors (lambda ()	; Ignore errors -- see note above.
-		   (apply really-send-http-error-reply reply-code req args))))
-
-(define (really-send-http-error-reply reply-code req . args)
-  (let* ((message (if (pair? args) (car args)))
-	 (extras  (if (pair? args) (cdr args) '()))
-
-	 (new-protocol? (and req (not (v0.9-request? req)))) ; 1.0 or better?
-
-	 ;; Is it OK to send back an HTML body explaining things?
-	 (html-ok? (or (not req)
-		       (not (string=? (request:method req) "HEAD"))))
-
-	 (out (current-output-port))
-
-	 (generic-title (lambda ()
-			  (title-html out
-				      (reply-code->text reply-code)
-				      new-protocol?)))
-
-	 (do-msg (lambda () (? (message (display message out) (newline out))))))
-
-    (if new-protocol? (begin-http-header out reply-code))
-
-    ;; Don't output the blank line, as individual clauses might
-    ;; want to add more headers.
-    (if html-ok? (write-string "Content-type: text/html\r\n" out))
-
-    ;; If html-ok?, we must send back some html, with the <body> tag unclosed.
-    (switch = reply-code
-
-      ;; This error reply requires two args: message is the new URI: field,
-      ;; and the first EXTRA is the older Location: field.
-      ((http-reply/moved-temp http-reply/moved-perm)
-       (when new-protocol?
-        (format out "URI: ~A\r~%" message)
-	 (format out "Location: ~A\r~%" (car extras)))
-       (when html-ok?
-	     (title-html out "Document moved" new-protocol?)
-	     (format out
-		     "This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
-		     (if (= reply-code http-reply/moved-temp) "temporarily" "permanently")
-		     message)))
-
-      ((http-reply/bad-request)
-       (when html-ok?
-	     (generic-title)
-	     (write-string "<P>Client sent a query that this server could not understand.\n"
-			   out)
-	     (if message (format out "<BR>~%Reason: ~A~%" message))))
-
-      ((http-reply/unauthorized)
-       (if new-protocol?
-	   (format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das?
-       (when html-ok?
-         (title-html out "Authorization Required" new-protocol?)
-	 (write-string "<P>Browser not authentication-capable or\n" out)
-	 (write-string "authentication failed.\n" out)
-	 (if message (format out "~a~%" message))))
-
-      ((http-reply/forbidden)
-       (unless html-ok?
-         (title-html out "Request not allowed." new-protocol?)
-	 (format out "Your client does not have permission to perform a ~A~%"
-		 (request:method req))
-	 (format out "operation on url ~a.~%" (request:uri req))
-	 (if message (format out "<P>~%~a~%" message))))
-
-      ((http-reply/not-found)
-       (when html-ok?
-         (title-html out "URL not found" new-protocol?)
-	 (write-string "<P>The requested URL was not found on this server.\n"
-		       out)
-	 (if message (format out "<P>~%~a~%" message))))
-
-      ((http-reply/internal-error)
-       (format (error-output-port) "ERROR: ~A~%" message)
-       (when html-ok? 
-         (generic-title)
-	 (format out "The server encountered an internal error or
-misconfiguration and was unable to complete your request.
-<P>
-Please inform the server administrator, ~A, of the circumstances leading to
-the error, and time it occured.~%"
-		 server/admin)
-	 (if message (format out "<P>~%~a~%" message))))
-
-      ((http-reply/not-implemented)
-       (when html-ok?
-         (generic-title)
-	 (format out "This server does not currently implement 
-the requested method (~A).~%"
-		 (request:method req))
-	 (if message (format out "<P>~a~%" message))))
-
-      (else (if html-ok? (generic-title))))
-
-    (? (html-ok?
-	;; Output extra stuff and close the <body> tag.
-	(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
-	(write-string "</BODY>\n" out)))
-    (force-output out)
-;   (if bkp? (breakpoint "http error"))
-    ))
-
-
-;;; Return my Internet host name (my fully-qualified domain name).
-;;; This works only if an actual resolver is behind host-info.
-;;;
-;;; On systems that do DNS via NIS/Yellow Pages, you only get an
-;;; unqualified hostname.  Also, in case of aliased names, you just
-;;; might get the wrong one.  Furthermore, you may get screwed in the
-;;; presence of a server accelerator such as Squid.
-;;;
-;;; In these cases, and on NeXTSTEP, you'll have to set it by hand.
-
-(define (my-fqdn addr)
-  (or *my-fqdn*
-      (host-info:name (host-info addr))))
-
-(define *my-fqdn* #f)
-(define (set-my-fqdn! fqdn)
-  (set! *my-fqdn* fqdn))
-
-(define (my-port addr)
-  (or *my-port*
-      (receive (ip-addr portnum) (socket-address->internet-address addr)
-	portnum)))
-(define *my-port* #f)
-(define (set-my-port! portnum)
-  (set! *my-port* portnum))

httpd-handlers.scm

@@ -1,534 +0,0 @@
-;;; http server in the Scheme Shell	-*- Scheme -*-
-;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
-
-;;; Imports and non-R4RS'isms
-;;;     scsh			syscalls
-;;; 	format			Formatted output
-;;; 	?, UNLESS, SWITCH	Conditionals
-;;;	httpd-core stuff
-;;; 	httpd error stuff
-;;; 	CONDITION-STUFF		Scheme 48 error conditions
-;;; 	url stuff
-
-;;; Path handlers
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Path handlers are the guys that actually perform the requested operation
-;;; on the URL. The handler interface is 
-;;;     (handler path-list request)
-;;; The path-list is a URL path list that is a suffix of REQUEST's url's
-;;; path-list. Path handlers can decide how to handle an operation by
-;;; recursively keying off of the elements in path-list. 
-;;; 
-;;; The object-oriented view:
-;;; One way to look at this is to think of the request's METHOD as a
-;;; generic operation on the URL. Recursive path handlers do method 
-;;; lookup to determine how to implement a given operation on a particular
-;;; path.
-;;;
-;;; The REQUEST is a request record, as defined in httpd-core.scm, containing
-;;; the details of the client request. However, path handlers should *not*
-;;; read the request entity from, or write the reply to the request's socket.
-;;; Path-handler I/O should be done on the current i/o ports: if the handler
-;;; needs to read an entity, it should read it from (CURRENT-INPUT-PORT); when
-;;; the handler wishes to write a reply, it should write it to 
-;;; (CURRENT-OUTPUT-PORT). This makes it easy for the procedure that called
-;;; the handler to establish I/O indirections or filters if it so desires.
-;;;
-;;; This file implements a basic set of path handlers and some useful
-;;; support procedures for them.
-
-
-(define server/buffer-size 8192)	; WTF
-
-
-;;; (alist-path-dispatcher hander-alist default-handler) -> handler
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; This function creates a table-driven path-handler that dispatches off
-;;; of the car of the request path. The handler uses the car to index into
-;;; a path-handler alist. If it finds a hit, it recurses using the table's
-;;; path-handler. If no hits, it handles the path with a default handler.
-;;; An alist handler is passed the tail of the original path; the
-;;; default handler gets the entire original path.
-;;;
-;;; This procedure is how you say: "If the first element of the URL's
-;;; path is 'foo', do X; if it's 'bar', do Y; otherwise, do Z." 
-
-(define (alist-path-dispatcher handler-alist default-handler)
-  (lambda (path req)
-    (? ((and (pair? path) (assoc (car path) handler-alist)) =>
-        (lambda (entry) ((cdr entry) (cdr path) req)))
-       (else (default-handler path req)))))
-
-
-;;; (home-dir-handler user-public-dir) -> handler
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Return a path handler that looks things up in a specific directory
-;;; in the user's home directory. If ph = (home-dir-handler "public_html")
-;;; then ph is a path-handler that serves files out of peoples' public_html
-;;; subdirectory. So
-;;;	(ph '("shivers" "hk.html") req)
-;;; will serve the file 
-;;;     ~shivers/public_html/hk.html
-;;; The path handler treats the URL path as (<user> . <file-path>),
-;;; serving
-;;;     ~<user>/<user-public-dir>/<file-path>
-
-(define (home-dir-handler user-public-dir)
-  (lambda (path req)		
-    (if (pair? path)
-	(serve-rooted-file-path (string-append (http-homedir (car path) req)
-					       "/"
-					       user-public-dir)
-				(cdr path)
-				file-serve
-				req)
-	(http-error http-reply/bad-request req
-		    "Path contains no home directory."))))
-
-;;; (tilde-home-dir-handler user-public-dir default)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"),
-;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
-;;; default handler.
-
-(define (tilde-home-dir-handler user-public-dir default-ph)
-  (lambda (path req)
-    (if (and (pair? path)			; Is it a ~foo/...
-	     (let ((head (car path)))		; home-directory path?
-	       (and (> (string-length head) 0)
-		    (char=? (string-ref head 0) #\~))))
-
-	(let* ((tilde-home (car path))		; Yes.
-	       (slen (string-length tilde-home))
-	       (subdir (string-append
-			 (http-homedir (substring tilde-home 1 slen) req)
-			 "/"
-			 user-public-dir)))
-	  (serve-rooted-file-path subdir (cdr path) file-serve req))
-
-	(default-ph path req))))		; No.
-
-
-;;; Make a handler that serves files relative to a particular root
-;;; in the file system. You may follow symlinks, but you can't back up
-;;; past ROOT with ..'s.
-
-(define (rooted-file-handler root)
-  (lambda (path req)
-    (serve-rooted-file-path root path file-serve req)))
-
-;;; Dito, but also serve directory indices for directories without
-;;; index.html.  ICON-NAME specifies how to generate the links to
-;;; various decorative icons for the listings.  It can either be a
-;;; prcoedure which gets passed one of the icon tags in TAG->ICON and
-;;; is expected to return a link pointing to the icon.  If it is a
-;;; string, that is taken as prefix to which the names from TAG->ICON
-;;; are appended.
-
-(define (rooted-file-or-directory-handler root icon-name)
-  (let ((file-serve-and-dir (file-server-and-dir icon-name)))
-    (lambda (path req)
-      (serve-rooted-file-path root path file-serve-and-dir req))))
-
-
-;;; The null path handler -- handles nothing, sends back an error reply.
-;;; Can be useful as the default in table-driven path handlers.
-
-(define (null-path-handler path req)
-  (http-error http-reply/not-found req))
-
-
-;;;; Support procs for the path handlers
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;;; (SERVE-ROOTED-FILE-PATH root file-path req)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Do a request for a file. The file-name is determined by appending the
-;;; the FILE-PATH list the string ROOT. E.g., if
-;;;     ROOT = "/usr/shivers"	FILE-PATH = ("a" "b" "c" "foo.html")
-;;; then we serve file
-;;;     /usr/shivers/a/b/c/foo.html
-;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
-;;;   (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path 
-;;;    sequences are processed away by the browser when the URI is converted
-;;;    to an absolute URI before it is sent off to the server.)
-;;; It is possible to sneak a .. past this kind of front-end resolving by
-;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
-;;; this, SERVE-ROOTED-FILE-PATH will catch it, and abort the transaction.
-;;; So you cannot make the reference back up past ROOT. E.g., this is
-;;; not allowed:
-;;;     FILE-PATH = ("a" "../.." "c" "foo.html")
-;;;
-;;; Only GET and HEAD ops are provided. 
-;;; The URL's <search> component must be #f.
-;;; The file is served if the server has read or stat(2) access to it,
-;;; respectively. If the server is run as root, this might be a problem.
-;;;
-;;; FILE-SERVE is a procedure which gets passed the file name, the
-;;; path, and the HTTP request to serve the file propert after the
-;;; security checks.  Look in ROOTED-FILE-HANDLER and
-;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
-
-(define (serve-rooted-file-path root file-path file-serve req)
-  (if (http-url:search (request:url req))
-      (http-error http-reply/bad-request req
-		  "Indexed search not provided for this URL.")
-
-      (? ((dotdot-check root file-path) =>
-	  (lambda (fname) (file-serve fname file-path req)))
-	 (else
-	  (http-error http-reply/bad-request req
-		      "URL contains unresolvable ..'s.")))))
-
-
-;; Just (file-info fname) with error handling.
-
-(define (stat-carefully fname req)
-  (with-errno-handler 
-   ((errno packet)
-    ((errno/noent)
-     (http-error http-reply/not-found req))
-    ((errno/acces)
-     (http-error http-reply/forbidden req)))
-   (file-info fname #t)))
-
-;;; A basic file request handler -- ship the dude the file. No fancy path
-;;; checking. That has presumably been taken care of. This handler only
-;;; takes care of GET and HEAD methods.
-
-(define (file-serve-or-dir fname file-path req directory-serve)
-  (if (file-name-directory? fname)	; Simple index generation.
-      (directory-serve fname file-path req)
-
-      (switch string=? (request:method req)
-	(("GET" "HEAD")			; Absolutely.
-	 (let ((info  (stat-carefully fname req)))
-	   (case (file-info:type info)
-
-	     ((regular fifo socket)
-	      (send-file fname info req))
-
-	     ((directory)		; Send back a redirection "foo" -> "foo/"
-	      (http-error http-reply/moved-perm req
-			  (string-append (request:uri req) "/")
-			  (string-append (http-url->string (request:url req))
-					 "/")))
-
-	     (else (http-error http-reply/forbidden req)))))
-
-	(else (http-error http-reply/method-not-allowed req)))))
-
-(define (directory-index-serve fname file-path req)
-  (file-serve (string-append fname "index.html") file-path req))
-
-(define (file-serve fname file-path req)
-  (file-serve-or-dir fname file-path req directory-index-serve))
-
-(define (tag->alt tag)
-  (case tag
-    ((directory) "[DIR]")
-    ((text) "[TXT]")
-    ((doc) "[DOC]")
-    ((image) "[IMG]")
-    ((movie) "[MVI]")
-    ((audio) "[AU ]")
-    ((archive) "[TAR]")
-    ((compressed) "[ZIP]")
-    ((uu) "[UU ]")
-    ((binhex) "[HQX]")
-    ((binary) "[BIN]")
-    (else "[   ]")))
-
-;; These icons can, for example, be found in the cern-httpd-3.0
-;; distribution at http://www.w3.org/pub/WWW/Daemon/
-
-(define (tag->icon tag)
-  (case tag
-    ((directory) "directory.xbm")
-    ((text) "text.xbm")
-    ((doc) "doc.xbm")
-    ((image) "image.xbm")
-    ((movie) "movie.xbm")
-    ((audio) "sound.xbm")
-    ((archive) "tar.xbm")
-    ((compressed) "compressed.xbm")
-    ((uu) "uu.xbm")
-    ((binhex) "binhex.xbm")
-    ((binary) "binary.xbm")
-    ((blank) "blank.xbm")
-    ((back) "back.xbm")
-    (else "unknown.xbm")))
- 
-(define (file-extension->tag fname)
-  (switch string-ci=? (file-name-extension fname)
-    ((".txt") 'text)
-    ((".doc" ".html" ".rtf" ".tex") 'doc)
-    ((".gif" ".jpg" ".jpeg" ".tiff" ".tif") 'image)
-    ((".mpeg" ".mpg") 'movie)
-    ((".au" ".snd" ".wav") 'audio)
-    ((".tar" ".zip" ".zoo") 'archive)
-    ((".gz" ".Z" ".z") 'compressed)
-    ((".uu") 'uu)
-    ((".hqx") 'binhex)
-    (else 'binary)))
-
-(define (file-tag fname type)
-  (case type
-    ((regular fifo socket) (file-extension->tag fname))
-    ((directory) 'directory)
-    (else 'unknown)))
-
-(define (time->directory-index-date-string time)
-  (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
-
-(define (read-max-lines fname max)
-  (call-with-input-file
-      fname
-    (lambda (port)
-      (let loop ((r "") (i max))
-	(if (zero? i)
-	    r
-	    (let ((line (read-line port)))
-	      (if (eof-object? line)
-		  r
-		  (loop (string-append r " " line) (- i 1)))))))))
-
-(define (string-cut s n)
-  (if (>= (string-length s) n)
-      (substring s 0 n)
-      s))
-
-(define html-file-header
-  (let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
-	(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
-    (lambda (fname n)
-      (let ((stuff (read-max-lines fname 10)))
-	(cond
-	 ((regexp-exec title-tag-regexp stuff)
-	  => (lambda (open-match)
-	       (cond
-		((regexp-exec title-close-tag-regexp stuff
-			      (match:end open-match))
-		 => (lambda (close-match)
-		      (string-cut (substring stuff
-					     (match:end open-match)
-					     (match:start close-match))
-				  n)))
-		(else (string-cut (substring stuff
-					     (match:end open-match)
-					     (string-length stuff))
-				  n)))))
-	 (else ""))))))
-
-(define (file-documentation fname n)
-  (cond
-   ((file-extension->content-type fname)
-    => (lambda (content-type)
-	 (if (and (string=? content-type "text/html" )
-		  (file-readable? fname))
-	     (html-file-header fname n)
-	     "")))
-   (else "")))
-
-(define (directory-index req dir icon-name)
-  
-  (define (pad-file-name file)
-    (write-string (make-string (- 21 (string-length file))
-			       #\space)))
-  
-  (define (emit-file-name file)
-    (let ((l (string-length file)))
-      (if (<= l 20)
-	  (emit-text file)
-	  (emit-text (substring file 0 20)))))
-  
-  (define (index-entry file)
-    (let* ((fname (directory-as-file-name (string-append dir file)))
-	   (info (stat-carefully fname req))
-	   (type (file-info:type info))
-	   (size (file-info:size info))
-	   (tag (file-tag file type)))
-      (emit-tag #t 'img
-		(cons 'src (icon-name tag))
-		(cons 'alt (tag->alt tag)))
-      (with-tag #t a ((href file))
-	(emit-file-name file))
-      (pad-file-name file)
-      (emit-text (time->directory-index-date-string (file-info:mtime info)))
-      (if size
-	  (let* ((size-string
-		  (string-append (number->string (quotient size 1024))
-				 "K"))
-		 (size-string
-		  (if (<= (string-length size-string) 7)
-		      size-string
-		      (string-append (number->string (quotient size (* 1024 1024)))
-				     "M")))
-		 (size-string
-		  (if (<= (string-length size-string) 8)
-		      (string-append
-		       (make-string (- 8 (string-length size-string)) #\space)
-		       size-string)
-		      size-string)))
-	    (write-string size-string))
-	  (write-string (make-string 8 #\space)))
-      (write-char #\space)
-      (emit-text (file-documentation fname 24))
-      (newline)))
-
-  (let ((files (with-errno-handler
-		((errno packet)
-		 ((errno/acces)
-		  (http-error http-reply/forbidden req)))
-		(directory-files dir))))
-    (for-each index-entry files)
-    (length files)))
-
-(define (directory-server icon-name)
-  (let ((icon-name
-	 (cond
-	  ((procedure? icon-name) icon-name)
-	  ((string? icon-name)
-	   (lambda (tag)
-	     (string-append icon-name (tag->icon tag))))
-	  (else tag->icon))))
-    (lambda (fname file-path req)
-      (switch string=? (request:method req)
-	(("GET" "HEAD")
-
-	 (unless (eq? 'directory (file-info:type (stat-carefully fname req)))
-	   (http-error http-reply/forbidden req))
-
-	 (unless (v0.9-request? req)
-	   (begin-http-header #t http-reply/ok)
-	   (write-string "Content-type: text/html\r\n")
-	   (write-string "\r\n"))
-
-	 (with-tag #t html ()
-	   (let ((title (string-append "Index of /"
-				       (join-strings file-path "/"))))
-	     (with-tag #t head ()
-	       (emit-title #t title))
-	     (with-tag #t body ()
-	       (emit-header #t 1 title)
-	       (with-tag #t pre ()
-		 (emit-tag #t 'img
-			   (cons 'src (icon-name 'blank))
-			   (cons 'alt "     "))
-		 (write-string "Name                 ")
-		 (write-string "Last modified          ")
-		 (write-string "Size   ")
-		 (write-string "Description")
-		 (emit-tag #t 'hr)
-		 (emit-tag #t 'img
-			   (cons 'src (icon-name 'back))
-			   (cons 'alt "[UP ]"))
-		 (unless (null? file-path)
-		   (with-tag #t a ((href ".."))
-		     (write-string "Parent directory"))
-		   (newline))
-		 (let ((n-files (directory-index req fname icon-name)))
-		   (emit-tag #t 'hr)
-		   (format #t "~d files" n-files)))))))
-	(else (http-error http-reply/method-not-allowed req))))))
-
-(define (index-or-directory-server icon-name)
-  (let ((directory-serve (directory-server icon-name)))
-    (lambda (fname file-path req)
-      (let ((index-fname (string-append fname "index.html")))
-	
-	(if (file-readable? index-fname)
-	    (file-serve index-fname file-path req)
-	    (directory-serve fname file-path req))))))
-  
-(define (file-server-and-dir icon-name)
-  (let ((index-or-directory-serve (index-or-directory-server icon-name)))
-    (lambda (fname file-path req)
-      (file-serve-or-dir fname file-path req index-or-directory-serve))))
-
-;;; Look up user's home directory, generating an HTTP error reply if you lose.
-
-(define (http-homedir username req)
-  (with-fatal-error-handler (lambda (c decline)
-			      (apply http-error http-reply/bad-request req
-				     "Couldn't find user's home directory."
-				     (condition-stuff c)))
-
-    (home-dir username)))
-
-
-(define (send-file filename info req)
-  (with-errno-handler ((errno packet)
-		       ((errno/acces)
-			(http-error http-reply/forbidden req))
-		       ((errno/noent)
-			(http-error http-reply/not-found req)))
-    (call-with-input-file filename
-      (lambda (in)
-	(let ((out (current-output-port)))
-	  (unless (v0.9-request? req)
-	    (begin-http-header out http-reply/ok)
-	    (receive (filename content-encoding)
-		(file-extension->content-encoding filename)
-	      (if content-encoding
-		  (format out "Content-encoding: ~A\r~%" content-encoding))
-	      (? ((file-extension->content-type filename) =>
-                  (lambda (ct) (format out "Content-type: ~A\r~%" ct)))))
-	    (format out "Last-modified: ~A\r~%"
-		    (time->http-date-string (file-info:mtime info)))
-	    (format out "Content-length: ~D\r~%" (file-info:size info))
-	    (write-string "\r\n" out))
-	  (copy-inport->outport in out))))))
-
-
-;;; Assemble a filename from ROOT and the elts of PATH-LIST.
-;;; If the assembled filename contains a .. subdirectory, return #f,
-;;; otw return the filename.
-
-(define dotdot-check
-  (let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)")))	; Matches a .. subdir.
-    (lambda (root path-list)
-      (let ((fname (if (null? path-list) root	; Bogus hack.
-		       (string-append (file-name-as-directory root)
-				      (join-strings path-list "/")))))
-	(and (not (regexp-exec dotdot-re fname))	; Check for .. subdir.
-	     fname)))))
-
-
-(define (file-extension->content-type fname)
-  (switch string-ci=? (file-name-extension fname)
-    ((".html")		"text/html")
-    ((".gif")		"image/gif")
-    ((".jpg" ".jpeg")	"image/jpeg")
-    ((".tiff" ".tif")	"image/tif")
-    ((".rtf")		"text/rtf")
-    ((".mpeg" ".mpg")	"video/mpeg")
-    ((".au" ".snd")	"audio/basic")
-    ((".wav")		"audio/x-wav")
-    ((".dvi")		"application/x-dvi")
-    ((".tex" ".latex")	"application/latex")
-    ((".zip")		"application/zip")
-    ((".tar")		"application/tar")
-    ((".ps") 		"application/postscript")
-    (else #f)))
-
-(define (file-extension->content-encoding fname)
-  (cond
-   ((switch string-ci=? (file-name-extension fname)
-      ((".Z")           "x-compress")
-      ((".gz")          "x-gzip")
-      (else #f))
-    => (lambda (encoding)
-	 (values (file-name-sans-extension fname) encoding)))
-   (else (values fname #f))))
-   
-;;; Timeout on network writes?
-
-(define (copy-inport->outport in out)
-  (let ((buf (make-string server/buffer-size)))
-    (let loop ()
-      (? ((read-string! buf in) => (lambda (nchars)
-				     (write-string buf out 0 nchars)
-				     (loop))))))
-  (force-output out))

modules.scm

@@ -1,374 +0,0 @@
-;;; Scheme 48 module definitions for TCP/IP protocol suites. 
-;;; Copyright (c) 1995 by Olin Shivers.
-
-(define-structures
-  ((smtp (export sendmail %sendmail
-		 expn vrfy mail-help
-		 smtp-transactions
-		 smtp-transactions/no-close
-		 smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
-		 smtp/send smtp/soml smtp/saml smtp/rset smtp/expn
-		 smtp/help smtp/noop smtp/quit smtp/turn
-		 handle-smtp-reply
-		 read-smtp-reply
-		 parse-smtp-reply
-		 smtp-stuff))
-   (smtp-internals (export read-crlf-line 	; These two should be in an
-			   write-crlf		; auxiliary module.
-
-			   smtp-query
-			   nullary-smtp-command
-			   unary-smtp-command)))
-
-				
-  (open scsh			; write-string read-string/partial force-output
-				;   system-name user-login-name and sockets
-	crlf-io			; read-crlf-line write-crlf
-	receiving		; values receive
-	let-opt			; let-optionals
-	error-package		; error
-	switch-syntax		; switchq
-	condhax			; ? for COND
-	scheme)
-  (files smtp))
-
-
-(define-structure crlf-io (export read-crlf-line
-				  write-crlf)
-  (open ascii		; ascii->char
-	scsh		; read-line write-string force-output
-	receiving	; MV return (RECEIVE and VALUES)
-	let-opt		; let-optionals
-	scheme)	
-  (files crlf-io))
-
-
-(define-structures ((switch-syntax  (export (switch  :syntax)
-					    (switchq :syntax)))
-		    (condhax (export (when   :syntax)
-				     (unless :syntax)
-				     (?      :syntax))))
-  (open scheme)
-  (files conditionals))
-
-
-(define-structure rfc822 (export  read-rfc822-headers
-				  read-rfc822-field
-				 %read-rfc822-headers
-				 %read-rfc822-field
-				 rejoin-header-lines
-				 get-header-all
-				 get-header-lines
-				 get-header
-				 )
-  (open receiving	; MV return (RECEIVE and VALUES)
-	condhax		; ? for COND
-	scsh-utilities	; index
-	let-opt         ; let-optionals
-	strings		; lowercase-string uppercase-string
-	crlf-io		; read-crlf-line
-	ascii		; ascii->char
-	error-package	; error
-	scsh		; join-strings
-	scheme)
-  (files rfc822))
-
-
-(define-structure strings (export string-map
-				  downcase-string
-				  upcase-string
-				  char-set-index
-				  char-set-rindex
-				  string-reduce
-				  skip-whitespace
-				  string-prefix?
-				  string-suffix?)
-  (open char-set-package let-opt scheme) 
-  (files stringhax))
-
-(define-structure uri-package (export parse-uri
-				      uri-escaped-chars
-				      unescape-uri
-				      escape-uri
-				      resolve-uri
-				      split-uri-path
-				      uri-path-list->path
-				      simplify-uri-path)
-  (open scsh-utilities
-	let-opt
-	receiving
-	condhax
-	ascii
-	strings
-	char-set-package
-	bitwise
-	field-reader-package
-	scheme)
-  (files uri))
-
-(define-structure url-package (export userhost?			; USERHOST
-				      make-userhost		; record struct
-
-				      userhost:user
-				      userhost:password
-				      userhost:host
-				      userhost:port
-
-				      set-userhost:user
-				      set-userhost:password
-				      set-userhost:host
-				      set-userhost:port
-				      
-				      parse-userhost		; parse &
-				      userhost->string		; unparse.
-
-				      http-url?			; HTTP-URL
-				      make-http-url		; record struct
-
-				      http-url:userhost
-				      http-url:path
-				      http-url:search
-				      http-url:frag-id
-
-				      set-http-url:userhost
-				      set-http-url:path
-				      set-http-url:search
-				      set-http-url:frag-id
-				      
-				      parse-http-url		; parse &
-				      http-url->string)		; unparse.
-
-  (open defrec-package
-	receiving
-	condhax
-	char-set-package
-	uri-package
-	scsh-utilities
-	httpd-error
-	scheme)
-  (files url))
-
-
-(define-structure httpd-error (export http-error?
-				      http-error
-				      fatal-syntax-error?
-				      fatal-syntax-error
-				      with-fatal-error-handler*
-				      (with-fatal-error-handler :syntax))
-  (open conditions signals handle scheme)
-  (files httpd-error))
-
-
-(define-structure httpd-core (export server/version
-				     server/protocol
-				     server/admin
-				     set-server/admin!
-
-				     http-log
-				     *http-log?*
-				     *http-log-port*
-
-				     httpd
-
-				     make-request 	; HTTP request
-				     request? 		; record type.
-				     request:method
-				     request:uri
-				     request:url
-				     request:version
-				     request:headers
-				     request:socket
-				     set-request:method
-				     set-request:uri
-				     set-request:url
-				     set-request:version
-				     set-request:headers
-				     set-request:socket
-
-				     version< version<=
-				     v0.9-request?
-				     version->string
-					   
-				     ;; Integer reply codes
-				     reply-code->text
-				     http-reply/ok
-				     http-reply/created
-				     http-reply/accepted
-				     http-reply/prov-info
-				     http-reply/no-content
-				     http-reply/mult-choice
-				     http-reply/moved-perm
-				     http-reply/moved-temp
-				     http-reply/method
-				     http-reply/not-mod
-				     http-reply/bad-request
-				     http-reply/unauthorized
-				     http-reply/payment-req
-				     http-reply/forbidden
-				     http-reply/not-found
-				     http-reply/method-not-allowed
-				     http-reply/none-acceptable
-				     http-reply/proxy-auth-required
-				     http-reply/timeout
-				     http-reply/conflict
-				     http-reply/gone
-				     http-reply/internal-error
-				     http-reply/not-implemented
-				     http-reply/bad-gateway
-				     http-reply/service-unavailable
-				     http-reply/gateway-timeout
-
-				     time->http-date-string
-				     begin-http-header
-				     send-http-error-reply
-
-				     set-my-fqdn!
-				     set-my-port!)
-  (open scsh
-	receiving
-	let-opt
-	crlf-io
-	rfc822
-	switch-syntax
-	condhax
-	strings
-	char-set-package
-	defrec-package
-	handle
-	conditions	; condition-stuff
-	defenum-package
-	httpd-error
-	uri-package
-	url-package
-	formats
-	scheme)
-  (files httpd-core))
-
-
-;;; For parsing submissions from HTML forms.
-(define-structure parse-html-forms (export parse-html-form-query unescape-uri+)
-  (open scsh scsh-utilities let-opt
-	receiving uri-package strings condhax scheme)
-  (files parse-forms))
-
-
-;;; For writing CGI scripts in Scheme.
-(define-structure cgi-script-package (export cgi-form-query)
-  (open scsh
-	switch-syntax
-	error-package
-	parse-html-forms
-	scheme)
-  (files cgi-script))
-
-;;; Provides the server interface to CGI scripts.
-(define-structure cgi-server-package (export cgi-default-bin-path
-					     cgi-handler
-					     initialise-request-invariant-cgi-env)
-  (open strings
-	rfc822
-	crlf-io			; WRITE-CRLF
-	uri-package
-	url-package		; HTTP-URL record type
-	httpd-core		; REQUEST record type, HTTP-ERROR & reply codes
-				;   version stuff
-	httpd-basic-handlers	; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
-	httpd-error		; HTTP-ERROR
-	scsh-utilities		; INDEX
-	scsh			; syscalls
-	formats			; format
-	condhax			; ? is COND
-	switch-syntax		; SWITCHQ
-	scheme)
-  (files cgi-server))
-
-(define-structure htmlout-package (export emit-tag
-					  emit-close-tag
-
-					  emit-p
-					  emit-title	
-					  emit-header	; And so forth...
-
-					  with-tag
-					  with-tag*
-
-					  escape-html
-					  emit-text)
-  (open scsh scsh-utilities strings formats ascii receiving scheme)
-  (files htmlout))
-
-(define-structure httpd-basic-handlers (export alist-path-dispatcher
-					       home-dir-handler
-					       tilde-home-dir-handler
-					       rooted-file-handler
-					       rooted-file-or-directory-handler
-					       null-path-handler
-					       serve-rooted-file-path
-					       file-serve
-					       file-server-and-dir
-					       http-homedir
-					       send-file
-					       dotdot-check
-					       file-extension->content-type
-					       copy-inport->outport)
-  (open scsh		; syscalls
-	formats		; FORMAT
-	condhax		; UNLESS, ? for COND
-	switch-syntax	; Conditionals
-	httpd-core	; REQUEST record type, HTTP-ERROR & reply codes,
-			; v0.9-request, begin-http-header
-	httpd-error
-	htmlout-package
-	conditions	; CONDITION-STUFF
-	url-package	; HTTP-URL record type
-	scheme)
-  (files httpd-handlers))
-
-
-(define-structure seval-handler-package (export seval-handler)
-  (open scsh		; syscalls & INDEX
-	condhax		; WHEN, ? for COND
-	switch-syntax	; Conditionals
-	httpd-error
-	httpd-core	; REQUEST  record type, HTTP-ERROR & reply codes,
-			; v0.9-request, reply formatting stuff.
-	uri-package	; UNESCAPE-URI
-	htmlout-package	; Formatted HTML output
-	error-package	; ERROR
-	pp		; Pretty-printer
-	strings rfc822
-	toothless-eval	; EVAL-SAFELY
-	handle		; IGNORE-ERROR
-	strings		; SKIP-WHITESPACE
-	parse-html-forms ; PARSE-HTML-FORM-QUERY
-	scheme)
-  (files seval))
-
-(define-structure httpd-access-control (export access-denier
-					       access-allower
-					       access-controller
-					       access-controlled-handler)
-  (open big-scheme
-	strings
-	httpd-core
-	httpd-error
-	scsh
-	scheme)
-  (files httpd-access-control))
-
-(define-structure info-gateway (export info-handler
-				       find-info-file
-				       info-gateway-error)
-  (open big-scheme
-	conditions signals handle
-	switch-syntax
-	condhax
-	strings
-	htmlout-package
-	httpd-core
-	httpd-error
-	url-package
-	uri-package
-	scsh
-	scheme)
-  (files info-gateway))

program-modules.scm

@@ -1,44 +0,0 @@
-;;; Scheme 48 module definitions for Scheme program execution. 
-;;; Gebhard Engelhart.
-
-(define-structure scheme-program-server-package (export scheme-program-handler
-						 runprogram)
-  (open strings
-	rfc822
-	crlf-io			; WRITE-CRLF
-	uri-package
-	url-package		; HTTP-URL record type
-	httpd-core		; REQUEST record type, HTTP-ERROR & reply codes
-				;   version stuff
-	httpd-basic-handlers	; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
-	httpd-error           	; HTTP-ERROR
-	scsh-utilities		; INDEX
-	scsh			; syscalls
-	formats			; format
-	condhax			; ? is COND
-	switch-syntax		; SWITCHQ
-	scheme)
-  (files scheme-program-server))
-
-;;; package to load scheme programs
-
-(define-structure scheme-programs-package (export testprog
-						  info2www)
-  (open scsh		; syscalls & INDEX
-	condhax		; WHEN, ? for COND
-	switch-syntax	; Conditionals
-	defrec-package  ; Records
-	htmlout-package	; Formatted HTML output
-	httpd-core      ; REQUEST record type, HTTP-ERROR & reply codes
-			; version stuff
-	uri-package	; UNESCAPE-URI
-	error-package	; ERROR
-	pp		; Pretty-printer
-	strings rfc822
-	toothless-eval	; EVAL-SAFELY
-	handle		; IGNORE-ERROR
-	strings		; SKIP-WHITESPACE
-	parse-html-forms ; PARSE-HTML-FORM-QUERY
-	scheme)
-  (files testprog
-	 info2www))

scheme-program-server.scm

@@ -1,58 +0,0 @@
-(define scheme-program-handler
-  (lambda (path req)
-    (if (pair? path)	; Got to have at least one elt.
-        (let* ((prog (car path))
-	      
-	       (search (http-url:search (request:url req)))	; Compute the
-	       (arglist (if (and search (not (index search #\=)))	; argv list.
-		         (split-and-decode-search-spec search)
-		         '()))
-	       (env (exec-env req (cdr path))) ; set global environment vars
-	       (doit (lambda ()
-		       ((runprogram prog) arglist))))
-
-	  (and (http-log "----------------------------------------~%")
-	       (http-log "  Programmname : ~s~%" prog)
-	       (http-log "  search       : ~s~%" search)
-	       (http-log "  Argumente    : ~s~%" arglist)
-	       (http-log "----------------------------------------~%")
-
-	       (switch string=? (request:method req)
-		       (("GET" "POST")		; Could do others also.
-			(wait (fork doit)))
-		       (else (http-error http-reply/method-not-allowed req)))))
-
-	  (http-error http-reply/bad-request req "Error "))))
-
-(define (runprogram progstring)
-    (let* ( (progsymbol (read (make-string-input-port progstring)))
-	    (progsymbol1 (string->symbol progstring)))
-      (and (http-log "[]run-program ~s ~s ~s~%" progstring progsymbol progsymbol1)
-	   (eval progsymbol (interaction-environment)))))
-
-(define (split-and-decode-search-spec s)
-  (let recur ((i 0))
-    (? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
-					     (recur (+ j 1)))))
-       (else (list (unescape-uri s i (string-length s)))))))
-
-(define url-path)
-(define script-path)
-(define script-name)
-(define (exec-env req  path-suffix)
-  (let* (;; Compute the $SCRIPT_PATH string.
-         (url-path1 (http-url:path (request:url req)))
-         (script-path1 (take (- (length url-path1) (length path-suffix))
-                            url-path1))
-         (script-name1 (uri-path-list->path script-path1)))
-    (and (set! url-path url-path1)
-	 (set! script-path script-path1)
-	 (set! script-name script-name1))))
-
-(define (take n lis)
-  (if (zero? n) '()
-      (cons (car lis) (take (- n 1) (cdr lis)))))
-
-(define (drop n lis)
-  (if (zero? n) lis
-      (drop (- n 1) (cdr lis))))

scheme/httpd/access-control.scm

@@ -1,14 +1,15 @@
 ;;; http server in the Scheme Shell	-*- Scheme -*-
-;;; Access control
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
 ;;; Copyright (c) 1996 by Mike Sperber. <sperber@informatik.uni-tuebingen.de>
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; This code is very rudimentary at the moment and up for some expansion.
 ;;; Right now, it is primarily useful for running the server through a
 ;;; web accelerator
 
-;;; Also notes that this code doesn't work in vanilla 0.4.4 as
-;;; host-info is broken.
-
 (define (access-denier . hosts)
   (lambda (info)
     (and (any? (lambda (host)
@@ -26,18 +27,16 @@
 (define (access-controller . controls)
   (lambda (info)
     (let loop ((controls controls))
-      (if (null? controls)
-	  #f
-	  (cond
-	   (((car controls) info) => identity)
-	   (else (loop (cdr controls))))))))
+      (and (pair? controls)
+	   (or ((car controls) info)
+	       (loop (cdr controls)))))))
 
 (define (access-controlled-handler control ph)
   (lambda (path req)
     (if (eq?
 	 (control (host-info (socket-remote-address (request:socket req))))
 	 'deny)
-	(http-error http-reply/forbidden req)
+	(http-error http-status/forbidden req)
 	(ph path req))))
 
 (define (address->list address)
@@ -55,12 +54,12 @@
 	    (host-info:addresses info))))
    (else ; (string? host)
     (any? (lambda (name)
-	    (string-match host (downcase-string name)))
+	    (string-match host (string-map char-downcase name)))
 	  (cons (host-info:name info)
 		(host-info:aliases info))))))
 
 (define normalize-host
-  (let ((split (infix-splitter "\\."))
+  (let ((split (infix-splitter (make-regexp "\\.")))
 	(number (make-regexp "[0-9]+")))
     (lambda (host)
       (let ((components (split host)))

scheme/httpd/cgi-server.scm

@@ -0,0 +1,300 @@
+;;; Server support for NCSA's WWW Common Gateway Interface -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
+
+;;; PROBLEMS: 
+;;;   - The handlers could be made -- closed over their parameters
+;;;     (e.g., root vars, etc.)
+
+;;; This code provides a path-handler for the HTTP server that implements 
+;;; a CGI interface to external programs for doing HTTP transactions.
+
+;;; About HTML forms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This info is in fact independent of CGI, but important to know about, 
+;;; as many CGI scripts are written for responding to forms-entry in
+;;; HTML browsers.
+;;;
+;;; The form's field data are turned into a single string, of the form
+;;;     name=val&name=val
+;;; where the <name> and <val> parts are URI encoded to hide their
+;;; &, =, and + chars, among other things. After URI encoding, the
+;;; space chars are converted to + chars, just for fun. It is important
+;;; to encode the spaces this way, because the perfectly general %xx escape
+;;; mechanism might be insufficiently confusing. This variant encoding is
+;;; called "form-url encoding."
+;;;
+;;; If the form's method is POST,
+;;;     Browser sends the form's field data in the entity block, e.g.,
+;;;     "button=on&ans=yes". The request's Content-type: is application/
+;;; 	x-www-form-urlencoded, and the request's Content-length: is the
+;;; 	number of bytes in the form data.
+;;;
+;;; If the form's method is GET,
+;;;     Browser sends the form's field data in the URL's <search> part.
+;;;     (So the server will pass to the CGI script as $QUERY_STRING,
+;;;     and perhaps also on in argv[]).
+;;;
+;;; In either case, the data is "form-url encoded" (as described above).
+
+;;; ISINDEX queries:
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; (Likewise for ISINDEX URL queries from browsers.)
+;;; Browser url-form encodes the query (see above), which then becomes the
+;;; ?<search> part of the URI. (Hence the CGI script will split the individual
+;;; fields into argv[].)
+
+
+;;; CGI interface:
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
+;;; - If it contains no raw "=" chars, it is split at "+" chars. The
+;;;   substrings are URI decoded, and become the elts of argv[].
+;;; - The CGI script is run with stdin hooked up to the socket. If it's going
+;;;   to read the entity, it should read $CONTENT_LENGTH bytes worth.
+;;; - A bunch of env vars are set; see below.
+;;; - If the script begins with "nph-" its output is the entire response.
+;;;   Otherwise, it replies to the server, we peel off a little header
+;;;   that is used to construct the real header for the response.
+;;; See the "spec" for further details. (URL above).
+;;;
+;;; The "spec" also talks about PUT, but when I tried this on a dummy script,
+;;; the NSCA httpd server generated buggy output. So I am only implementing
+;;; the POST and GET ops; any other op generates a "405 Method not allowed"
+;;; response.
+
+;;; Parameters
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; path for scripts 
+(define cgi-default-bin-path "/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin")
+
+;;; The path handler for CGI scripts. (car path) is the script to run.
+;;; cgi-bin-path is used, if PATH-variable isn't defined
+
+(define (cgi-handler bin-dir . maybe-cgi-bin-path)
+  (let-optionals
+      maybe-cgi-bin-path
+      ((cgi-bin-path cgi-default-bin-path))
+    
+    (let ((request-invariant-cgi-env    ; environment variables that never change
+	   `(("PATH"              . ,(and (getenv "PATH") cgi-bin-path))
+	     ("SERVER_SOFTWARE"   . ,sunet-version-identifier)
+	     ("SERVER_NAME"       . ,(host-info:name (host-info (system-name))))
+	     ("GATEWAY_INTERFACE" . "CGI/1.1"))))
+      (lambda (path req)
+	(if (pair? path)	; Got to have at least one elt.
+	    (compute-cgi path req bin-dir request-invariant-cgi-env)
+	    (make-http-error-response http-status/bad-request req "Empty CGI script"))))))
+
+(define (compute-cgi path req bin-dir request-invariant-cgi-env)
+  (let* ((prog (car path))
+
+	 (filename (or (dotdot-check bin-dir (list prog))
+		       (http-error http-status/bad-request req 
+				   "CGI scripts may not contain \"..\" elements.")))
+
+	 (nph? (string-prefix? "nph-" prog))	; PROG starts with "nph-" ? 
+					; why did we had (string-suffix? "-nph" prog) here?
+
+	 (search (http-url:search (request:url req)))	; Compute the
+	 (argv (if (and search (not (string-index search #\=)))	; argv list.
+		   (split-and-decode-search-spec search)
+		   '()))
+
+	 (env (cgi-env req bin-dir (cdr path) request-invariant-cgi-env))
+
+	 (doit (lambda ()
+		 (dup->inport  (current-input-port) 0)
+		 (dup->outport (current-output-port) 1)
+		 (dup 1 2)
+		 (apply exec/env filename env argv))))
+
+    (http-syslog (syslog-level debug) "[cgi-server] search: ~s, argv: ~s~%" search argv)
+    (let ((request-method (request:method req)))
+      (cond 
+       ((or (string=? request-method "GET")
+	    (string=? request-method "POST"))	; Could do others also.
+	(if nph?
+	    (let ((stat (wait (fork doit))))
+	      (if (not (zero? stat))
+		  (make-http-error-response 
+		   http-status/bad-request req
+		   (format #f "Could not execute CGI script ~a." 
+			   filename)) 
+		  stat))		;; FIXME! must return http-response object!
+	    (case (file-not-executable? filename)
+	      ((search-denied permission)
+	       (make-http-error-response http-status/forbidden req
+					 "Permission denied."))
+	      ((no-directory nonexistent)
+	       (make-http-error-response http-status/not-found req
+					 "File or directory doesn't exist."))
+	      (else
+	       (cgi-make-response (run/port* doit) path req)))))
+       
+       (else 
+	(make-http-error-response http-status/method-not-allowed req request-method))))))
+
+
+(define (split-and-decode-search-spec s)
+  (let recur ((i 0))
+    (cond
+     ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
+						  (recur (+ j 1)))))
+     (else (list (unescape-uri s i (string-length s)))))))
+
+
+;;; Compute the CGI scripts' process environment by adding the standard CGI
+;;; environment var bindings to the current process env -- return result
+;;; as an alist.
+;;;
+;;; You are also supposed to add the headers as env vars in a particular
+;;; format, but are allowed to bag it if the environment var storage 
+;;; requirements might overload the OS. I don't know what you can rely upon
+;;; in Unix, so I am just bagging it, period.
+;;;
+;;; Suppose the URL is
+;;;   //machine/cgi-bin/test-script/foo/bar?quux%20a+b=c
+;;; then:
+;;   PATH_INFO -- extra info after the script-name path prefix. "/foo/bar"
+;;;   PATH_TRANSLATED -- non-virtual version of above.  "/u/Web/foo/bar/"
+;;;   SCRIPT_NAME virtual path to script "/cgi-bin/test-script"
+;;;   QUERY_STRING -- not decoded "quux%20a+b=c"
+;;; The first three of these vars are *not* encoded, so information is lost
+;;; if the URL's path elements contain encoded /'s (%2F). CGI loses.
+
+(define (cgi-env req bin-dir path-suffix request-invariant-cgi-env)
+  (let* ((sock (request:socket req))
+	 (raddr (socket-remote-address sock))
+
+	 (headers (request:headers req))
+
+	 ;; Compute the $PATH_INFO and $PATH_TRANSLATED strings.
+	 (path-info (uri-path-list->path 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-list->path script-path)))
+
+    (receive (rhost rport)
+	     (socket-address->internet-address raddr)
+      (receive (lhost lport)
+               (socket-address->internet-address (socket-local-address sock))
+
+	`(("SERVER_PROTOCOL" . ,(version->string (request:version req)))
+	  ("SERVER_PORT"     . ,(number->string lport))
+	  ("REQUEST_METHOD"  . ,(request:method req))
+
+	  ("PATH_INFO"       . ,path-info)
+	  ("PATH_TRANSLATED" . ,path-translated)
+	  ("SCRIPT_NAME"     . ,script-name)
+
+	  ("REMOTE_HOST"  . ,(host-name-or-ip raddr))
+	  ("REMOTE_ADDR"  . ,(format-internet-host-address rhost))
+
+	  ;; ("AUTH_TYPE" . xx)			; Random authentication
+	  ;; ("REMOTE_USER" . xx)		; features I don't understand.
+	  ;; ("REMOTE_IDENT" . xx)
+
+	  ,@request-invariant-cgi-env	; Stuff that never changes (see cgi-handler).
+
+	  ,@(cond ((http-url:search (request:url req)) =>
+		   (lambda (srch) `(("QUERY_STRING" . ,srch))))
+		  (else '()))
+
+	  ,@(cond ((get-header headers 'content-type) =>
+		   (lambda (ct) `(("CONTENT_TYPE" . ,ct))))
+		  (else '()))
+
+	  ,@(cond ((get-header headers 'content-length) =>
+		   (lambda (cl)	; Skip initial whitespace (& other non-digits).
+		     (let ((first-digit (string-index cl char-set:digit))
+			   (cl-len (string-length cl)))
+		       (if first-digit
+			   `(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
+			   (http-error http-status/bad-request req 
+				       "Illegal `Content-length:' header.")))))
+		  
+		  (else '()))
+	  
+	  . ,(env->alist))))))
+
+
+(define (take n lis)
+  (if (zero? n) '()
+      (cons (car lis) (take (- n 1) (cdr lis)))))
+
+(define (drop n lis)
+  (if (zero? n) lis
+      (drop (- n 1) (cdr lis))))
+
+
+;;; Script's output for request REQ is available on SCRIPT-PORT.
+;;; The script isn't an "nph-" script, so we read the response, and mutate
+;;; it into a real HTTP response, which we then send back to the HTTP client.
+
+(define (cgi-make-response script-port path req)
+  (let* ((headers (read-rfc822-headers script-port))
+	 (ctype (get-header headers 'content-type))	; The script headers
+	 (loc   (get-header headers 'location))
+	 (stat  (extract-status-code-and-text 
+		 (get-header-lines headers 'status) req))
+	 (extra-headers (delete-headers (delete-headers (delete-headers headers 
+									'content-type)
+							'location)
+					'status)))
+    
+    (http-syslog (syslog-level debug) "[cgi-server] headers: ~s~%" headers)
+    (http-syslog (syslog-level debug) "[cgi-server] request:method=~a~%" 
+		 (request:method req))
+
+    (if loc
+	(if (uri-has-protocol? (string-trim loc))
+	    (make-http-error-response http-status/moved-perm req
+				      loc loc)
+	    (make-redirect-response (string-trim loc)))
+	;; Send the response header back to the client
+	(make-response ;code message seconds mime extras body
+	 (car stat)			; code
+	 (cdr stat)			; text
+	 (time)
+	 ctype
+	 extra-headers
+	 (make-writer-body
+	  (lambda (out options)
+	    (copy-inport->outport script-port out)
+	    (close-input-port script-port)))))))
+
+
+(define (uri-has-protocol? loc)
+  (receive (proto path search frag)
+      (parse-uri loc)
+    (if proto #t #f)))
+
+(define (extract-status-code-and-text stat-lines req)
+  (cond 
+   ((not (pair? stat-lines))	    ; No status header.
+    (cons http-status/ok "The idiot CGI script left out the status line."))
+   ((null? (cdr stat-lines)) 	    ; One line status header.
+    (with-fatal-error-handler*
+       (lambda (c d)
+	 (http-error http-status/bad-gateway req
+		     "CGI script generated an invalid status header."
+		     (car stat-lines) c))
+       (lambda ()
+	 (let ((status (string-trim (car stat-lines))))
+	   (cons (string->number (substring status 0 3))	; number
+		 (substring/shared status 4))))))		; text
+   (else			    ; Vas ist das?
+    (http-error http-status/bad-gateway req
+		"CGI script generated multi-line status header."))))

scheme/httpd/core.scm

@@ -0,0 +1,366 @@
+;;; http server in the Scheme Shell	-*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
+;;; Copyright (c) 1996-2002 by Mike Sperber.
+;;; Copyright (c) 2000-2002 by Martin Gasbichler.
+;;; Copyright (c) 2002 by Andreas Bernauer.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+
+;;; This file implements the core of an HTTP server: code to establish
+;;; net connections, read and parse requests, and handler errors. 
+;;; It does not have the code to actually handle requests. That's up
+;;; to other modules, and could vary from server to server. To build
+;;; a complete server, you need to define path 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
+
+;;; (httpd options)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The server top-level. PATH-HANDLER is the top-level request path handler --
+;;; the procedure that actually deals with the request.
+
+(define server/protocol "HTTP/1.0")
+
+(define (httpd options)
+  (let ((port (httpd-options-port options))
+	(root-dir (httpd-options-root-directory options))
+	(rate-limiter
+	 (cond
+	  ((httpd-options-simultaneous-requests options)
+	   => make-rate-limiter)
+	  (else #f))))
+    (let-thread-fluid 
+     logging 
+     (make-logging)
+     (lambda ()
+
+       (init-http-log! options)
+       (with-syslog-destination
+	"httpd" #f #f #f
+	(lambda ()
+	  (with-cwd
+	   root-dir
+	   (bind-listen-accept-loop
+	    protocol-family/internet
+	    ;; Why is the output socket unbuffered? So that if the client
+	    ;; closes the connection, we won't lose when we try to close the
+	    ;; socket by trying to flush the output buffer.
+	    (lambda (sock addr)
+	      (if rate-limiter
+		  (begin
+		    (rate-limit-block rate-limiter)
+		    (rate-limit-open rate-limiter)))
+
+	      (with-fatal-error-handler
+	       (lambda (c decline)
+		 (http-syslog (syslog-level notice) "error during connection negotiation~%")
+		 (if rate-limiter
+		     (rate-limit-close rate-limiter)))
+	       (call-with-values
+		(lambda ()
+		  (socket-address->internet-address (socket-remote-address sock)))
+		(lambda (host-address service-port)
+		  (if (and rate-limiter (http-syslog?))
+		      (http-syslog (syslog-level info) "<~a>~a: concurrent request #~a~%"
+				   (pid)
+				   (format-internet-host-address host-address)
+				   (rate-limiter-current-requests rate-limiter)))
+
+		  (set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
+		  (fork-thread 
+		   (lambda ()	
+		     (set-port-buffering (current-input-port) bufpol/none)
+		     (process-toplevel-request sock host-address options)
+		     (if (http-syslog?)
+			 (http-syslog (syslog-level debug) "<~a>~a [closing]~%"
+				      (pid)
+				      (format-internet-host-address host-address)))
+		     (with-fatal-error-handler
+		      (lambda (c decline)
+			(if (http-syslog?)
+			    (http-syslog (syslog-level notice) "<~a>~a [error closing (~a)]~%"
+					 (pid)
+					 (format-internet-host-address host-address)
+					 c)))
+		      (close-socket sock))
+		     (if rate-limiter
+			 (rate-limit-close rate-limiter))
+		     (if (http-syslog?)
+			 (http-syslog (syslog-level info) "<~a>~a [closed]~%"
+				      (pid)
+				      (format-internet-host-address host-address)))))))))
+	    port))))))))
+
+
+;;; Top-level http request processor
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Read, parse, and handle a single http request. The only thing that makes
+;;; this complicated is handling errors -- as a server, we can't just let the
+;;; standard error handlers toss us into a breakpoint. We have to catch the
+;;; error, send an error response back to the client if we can, and then keep
+;;; on trucking. This means using the S48's condition system to catch and
+;;; handle the various errors, which introduces a major point of R5RS
+;;; incompatibiliy -- R5RS has no exception system. So if you were to port
+;;; this code to some other Scheme, you'd really have to sit down and think
+;;; about this issue for a minute.
+
+(define (process-toplevel-request sock host-address options)
+  ;; This top-level error-handler catches *all* uncaught errors and warnings.
+  ;; If the error condition is a reportable HTTP error, we send a response back 
+  ;; to the client. In any event, we abort the transaction, and return from
+  ;; PROCESS-TOPLEVEL-REQUEST.
+  ;;
+  ;; We *oughta* map non-http-errors into replies anyway.
+  (with-fatal-error-handler*
+   (lambda (c decline)
+     (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
+		  (pid)
+		  (format-internet-host-address host-address)
+		  c)
+     (with-fatal-error-handler*
+      (lambda (c decline)
+	(http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%"
+		     (pid)
+		     (format-internet-host-address host-address)
+		     c))
+      (lambda ()
+	(shutdown-socket sock shutdown/sends+receives)
+	(http-syslog (syslog-level info) "<~a>~a [shut down]~%"
+		     (pid)
+		     (format-internet-host-address host-address))
+	(decline))))
+   (lambda ()
+     (call-with-values
+      (lambda ()
+	(with-fatal-error-handler*
+	 (lambda (c decline)
+	   (http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
+			(pid)
+			(format-internet-host-address host-address)
+			c)
+	   (cond
+	    ((http-error? c)
+	     (apply (lambda (status-code req . args)
+		      (values req
+			      (apply make-http-error-response
+				     status-code req
+				     args)))
+		    (condition-stuff c)))
+	    ((fatal-syntax-error? c)
+	     (values #f
+		     (apply make-http-error-response http-status/bad-request
+			    #f		; No request yet.	
+			    "Request parsing error -- report to client maintainer."
+			    (condition-stuff c))))
+	    ((not (and (exception? c)
+		       (eq? (exception-reason c)
+			    (enum exception os-error))))
+
+	     ;; try to send bug report to client
+	     (values #f
+		     (apply make-http-error-response http-status/internal-error 
+			    #f		; don't know
+			    "Internal error occured while processing request"
+			    c)))
+	    (else
+	     (decline))))
+	 (lambda ()
+	   (let ((initial-req (parse-http-request sock options)))
+	     (let redirect-loop ((req initial-req))
+	       (let ((response ((httpd-options-path-handler options)
+				(http-url:path (request:url req))
+				req)))
+	       (if (eq? (response-code response) 
+			http-status/redirect)
+		   (redirect-loop (redirect-request req response sock options))
+		   (values req response))))))))
+      (lambda (req response)
+
+	(send-http-response req response 
+			    (socket:inport sock)
+			    (socket:outport sock)
+			    options)
+	)))))
+
+(define (redirect-request req response socket options)
+  (let* ((new-location-uri (redirect-body-location (response-body response)))
+	 (url (with-fatal-error-handler*
+	       (lambda (c decline)
+		 (if (fatal-syntax-error? c)
+		     (http-error http-status/internal-error req
+				 (format #f "Bad redirection out from CGI program: ~%~a"
+					 (cdr c)))
+		     (decline c)))
+	       (lambda ()
+		 ;; (future) NOTE: With this, a redirection may change the
+		 ;; protocol in use (currently, the server only supports one of
+		 ;; it). This might be inapplicable.
+		 (parse-http-servers-url-fragment new-location-uri socket options)))))
+    
+    (make-request "GET"
+		  new-location-uri
+		  url
+		  (request:version req)	; did not change
+		  '()			; no rfc822 headers
+		  (request:socket req))))
+
+;;;; HTTP request parsing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; This code provides procedures to read requests from an input
+;;;; port.
+
+;;; Read and parse an http request from INPORT.
+;;; 
+;;; Note: this parser parses the URI into an http URL record. If the URI
+;;; isn't an http URL, the parser fails. This may not be right. There's
+;;; nothing in the http protocol to prevent you from passing a non-http
+;;; URI -- what this would mean, however, is not clear. Like so much of
+;;; the Web, the protocols are redundant, underconstrained, and ill-specified.
+
+(define (parse-http-request sock options)
+  (let ((line (read-crlf-line (socket:inport sock))))
+    ;; Blat out some logging info.
+    (if (http-syslog?)
+	(call-with-values
+	 (lambda ()
+	   (socket-address->internet-address (socket-remote-address sock)))
+	 (lambda (host-address service-port)
+	   (http-syslog (syslog-level info) "<~a>~a: ~a~%"
+		     (pid)
+		     (format-internet-host-address host-address)
+		     line))))
+    
+    (if (eof-object? line)
+	(fatal-syntax-error "EOF while parsing request.")
+
+	(let* ((elts (string->words line))	; Split at white-space.
+	       (version (case (length elts)
+			  ((2) '(0 . 9))
+			  ((3) (parse-http-version (caddr elts)))
+			  (else (fatal-syntax-error "Bad HTTP version.")))))
+
+	  (let* ((meth (car elts))
+		 (uri-string (cadr elts))
+		 (url (parse-http-servers-url-fragment uri-string sock options))
+		 (headers (if (equal? version '(0 . 9)) '()
+			      (read-rfc822-headers (socket:inport sock)))))
+	    (make-request meth uri-string url version headers sock))))))
+
+		
+
+;;; Parse the URL, but if it begins without the "http://host:port"
+;;; prefix, interpolate one from SOCKET. It would be sleazier but
+;;; faster if we just computed the default host and port at
+;;; server-startup time, instead of on every request.
+;;; REDIRECT-REQUEST relys on that nothing is read out from SOCKET.
+
+(define (parse-http-servers-url-fragment uri-string socket options)
+  (receive (scheme path search frag-id) (parse-uri uri-string)
+    (if frag-id				; Can't have a #frag part.
+	(fatal-syntax-error "HTTP URL contains illegal #<fragment> suffix."
+			    uri-string)
+
+	(if scheme
+	    (if (string-ci=? scheme "http") ; Better be an http url.
+		(parse-http-url path search #f)
+		(fatal-syntax-error "Non-HTTP URL" uri-string))
+
+	    ;; Interpolate the userhost struct from our net connection.
+	    (if (and (pair? path) (string=? (car path) ""))
+		(let* ((addr (socket-local-address socket))
+		       (local-name (or (httpd-options-fqdn options)
+				       (socket-address->fqdn addr #t)))
+		       (portnum (or (httpd-options-reported-port options)
+				    (my-reported-port addr))))
+		  (make-http-url (make-userhost #f #f
+						local-name
+						(number->string portnum))
+				 (map unescape-uri (cdr path)) ; Skip initial /.
+				 search
+				 #f))
+
+		(fatal-syntax-error "Path fragment must begin with slash"
+				    uri-string))))))
+
+
+(define parse-http-version
+  (let ((re (make-regexp "^HTTP/([0-9]+)\\.([0-9]+)$"))
+	(lose (lambda (s) (fatal-syntax-error "Bad HTTP version" s))))
+    (lambda (vstring)
+      (let ((m (regexp-exec re vstring)))
+	(if m
+	    (cons (or (string->number (match:substring m 1) 10) (lose vstring))
+		  (or (string->number (match:substring m 2) 10) (lose vstring)))
+	    (lose vstring))))))
+				      
+
+;;; Split string into a list of whitespace-separated strings.
+;;; This could have been trivially defined in scsh as (field-splitter " \t\n")
+;;; but I hand-coded it because it's short, and I didn't want invoke the
+;;; regexp machinery for something so simple.
+
+(define non-whitespace (char-set-complement char-set:whitespace))
+
+(define (string->words s)
+  (let recur ((start 0))
+    (cond ((string-index s non-whitespace start) =>
+        (lambda (start)
+	  (cond ((string-index s char-set:whitespace start) => 
+	      (lambda (end)
+		(cons (substring s start end)
+		      (recur end))))
+	     (else (list (substring s start (string-length s)))))))
+       (else '()))))
+
+(define (send-http-headers response port)
+  (display server/protocol port)
+  (write-char #\space port)
+  (display (response-code response) port)
+  (write-char #\space port)
+  (display (response-message response) port)
+  (write-crlf port)
+
+  (send-http-header-fields
+   (list (cons 'server (string-append "Scheme Untergrund " sunet-version-identifier))
+	 (cons 'content-type (response-mime response))
+	 (cons 'date (time->http-date-string (response-seconds response))))
+   port)
+  (send-http-header-fields (response-extras response) port)
+
+  (write-crlf port))
+
+(define (send-http-response request response input-port output-port options)
+
+  (if request
+      (begin
+	(if (not (v0.9-request? request))
+	    (send-http-headers response output-port))
+
+	(if (not (string=? (request:method request) "HEAD"))
+	    (display-http-body (response-body response) input-port output-port options))
+
+	(http-log request (response-code response)))
+      (begin
+	;; We have a bad request error. Try to report this headerless.
+	(display-http-body (response-body response) input-port output-port options)
+	;; no CLF-logging
+	)))
+
+(define (send-http-header-fields headers port)
+  (for-each (lambda (pair)
+	      (display (car pair) port)
+	      (display ": " port)
+	      (display (cdr pair) port)
+	      (write-crlf port))
+	    headers))
+
+(define (my-reported-port addr)
+  (receive (ip-addr portnum) (socket-address->internet-address addr)
+    portnum))
+

scheme/httpd/error.scm

@@ -0,0 +1,41 @@
+;;; Error stuff for the http server. -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; An http error condition is a data structure with the following pieces:
+;;;     (error-code request message . irritants)
+;;; You recognise one with HTTP-ERROR?, and retrieve the pieces with
+;;; CONDITION-STUFF.
+;;;
+
+;;; HTTP error condition
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Define a sub-type of the S48 error condition, the HTTP error condition.
+;;; An HTTP error is one that corresponds to one of the HTTP error response
+;;; codes, so you can reliably use an HTTP error condition to construct an
+;;; error response message to send back to the HTTP client.
+
+(define-condition-type 'http-error '(error))
+
+(define http-error? (condition-predicate 'http-error))
+
+(define (http-error status-code req . args)
+  (apply signal 'http-error status-code req args))
+
+;;; Syntax error condition
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Scheme 48 has a "syntax error" error condition, but it isn't an error
+;;; condition! It's a warning condition. I don't understand this. 
+;;; We define a *fatal* syntax error here for the parsers to use.
+
+(define-condition-type 'fatal-syntax-error '(error))
+
+(define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
+
+(define (fatal-syntax-error msg . irritants)
+  (apply signal 'fatal-syntax-error msg irritants))
+

scheme/httpd/file-dir-handler.scm

@@ -0,0 +1,496 @@
+;;; http server in the Scheme Shell	-*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
+;;; Copyright (c) 1996-2002 by Mike Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+(define server/buffer-size 8192)	; WTF
+
+;;; (home-dir-handler user-public-dir) -> handler
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Return a path handler that looks things up in a specific directory
+;;; in the user's home directory. If ph = (home-dir-handler "public_html")
+;;; then ph is a path-handler that serves files out of peoples' public_html
+;;; subdirectory. So
+;;;	(ph '("shivers" "hk.html") req)
+;;; will serve the file 
+;;;     ~shivers/public_html/hk.html
+;;; The path handler treats the URL path as (<user> . <file-path>),
+;;; serving
+;;;     ~<user>/<user-public-dir>/<file-path>
+
+(define (home-dir-handler user-public-dir)
+  (lambda (path req)		
+    (if (null? path)
+	(make-http-error-response http-status/bad-request
+				  req
+				  "Path contains no home directory.")
+	(make-rooted-file-path-response (string-append (http-homedir (car path) req)
+						       "/"
+						       user-public-dir)
+					(cdr path)
+					file-serve-response
+					req))))
+
+;;; (tilde-home-dir-handler user-public-dir default-path-handler)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"),
+;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
+;;; default handler.
+
+(define (tilde-home-dir? path req)
+  (and (not (null? path))
+       (let ((head (car path)))		; home-directory path?
+	 (and (> (string-length head) 0)
+	      (char=? (string-ref head 0) #\~)))))
+
+(define (tilde-home-dir-handler user-public-dir default-ph)
+  (make-request-handler
+   tilde-home-dir?
+   (lambda (path req)
+     (let* ((tilde-home (car path))	; Yes.
+	    (slen (string-length tilde-home))
+	    (subdir (string-append
+		     (http-homedir (substring tilde-home 1 slen) req)
+		     "/"
+		     user-public-dir)))
+       (make-rooted-file-path-response subdir (cdr path) file-serve-response req)))
+   default-ph))
+
+
+;;; Make a handler that serves files relative to a particular root
+;;; in the file system. You may follow symlinks, but you can't back up
+;;; past ROOT with ..'s.
+
+(define (rooted-file-handler root)
+  (lambda (path req)
+    (make-rooted-file-path-response root path file-serve-response req)))
+
+;;; Dito, but also serve directory indices for directories without
+;;; index.html. 
+
+(define (rooted-file-or-directory-handler root)
+  (lambda (path req)
+    (make-rooted-file-path-response root path
+				    file-serve-and-dir-response
+				    req)))
+
+
+;;;; Support procs for the path handlers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Do a request for a file. The file-name is determined by appending the
+;;; the FILE-PATH list the string ROOT. E.g., if
+;;;     ROOT = "/usr/shivers"	FILE-PATH = ("a" "b" "c" "foo.html")
+;;; then we serve file
+;;;     /usr/shivers/a/b/c/foo.html
+;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
+;;;   (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path 
+;;;    sequences are processed away by the browser when the URI is converted
+;;;    to an absolute URI before it is sent off to the server.)
+;;; It is possible to sneak a .. past this kind of front-end resolving by
+;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
+;;; this, MAKE-ROOTED-FILE-PATH-RESPONSE will catch it, and abort the transaction.
+;;; So you cannot make the reference back up past ROOT. E.g., this is
+;;; not allowed:
+;;;     FILE-PATH = ("a" "../.." "c" "foo.html")
+;;;
+;;; Only GET and HEAD ops are provided. 
+;;; The URL's <search> component must be #f.
+;;; The file is served if the server has read or stat(2) access to it,
+;;; respectively. If the server is run as root, this might be a problem.
+;;;
+;;; FILE-SERVE is a procedure which gets passed the file name, the
+;;; path, and the HTTP request to serve the file propert after the
+;;; security checks.  Look in ROOTED-FILE-HANDLER and
+;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
+
+(define (make-rooted-file-path-response root file-path file-serve-response req)
+  (if (http-url:search (request:url req))
+      (make-http-error-response http-status/bad-request req
+				"Indexed search not provided for this URL.")
+      (cond ((dotdot-check root file-path) =>
+	     (lambda (fname)
+	       (file-serve-response fname file-path req)))
+	    (else
+	     (make-http-error-response http-status/bad-request req
+				       "URL contains unresolvable ..'s.")))))
+
+
+;; Just (file-info fname) with error handling.
+
+(define (stat-carefully fname req)
+  (with-errno-handler 
+   ((errno packet)
+    ((errno/noent)
+     (http-error http-status/not-found req))
+    ((errno/acces)
+     (http-error http-status/forbidden req)))
+   (file-info fname #t)))
+
+;;; A basic file request handler -- ship the dude the file. No fancy path
+;;; checking. That has presumably been taken care of. This handler only
+;;; takes care of GET and HEAD methods.
+
+(define (file-serve-or-dir-response fname file-path req directory-serve-response)
+  (if (file-name-directory? fname)	; Simple index generation.
+      (directory-serve-response fname file-path req)
+      
+      (let ((request-method (request:method req)))
+	(cond
+	 ((or (string=? request-method "GET")
+	      (string=? request-method "HEAD")) ; Absolutely.
+	  (let ((info  (stat-carefully fname req)))
+	    (case (file-info:type info)
+	      
+	      ((regular fifo socket)
+	       (send-file-response fname info req))
+	      
+	      ((directory)		; Send back a redirection "foo" -> "foo/"
+	       (make-http-error-response
+		http-status/moved-perm req
+		(string-append (request:uri req) "/")
+		(string-append (http-url->string (request:url req))
+			       "/")))
+
+	      (else (make-http-error-response http-status/forbidden req)))))
+	 
+	 (else 
+	  (make-http-error-response http-status/method-not-allowed req 
+				    request-method))))))
+
+(define (directory-index-serve-response fname file-path req)
+  (file-serve-response (string-append fname "index.html") file-path req))
+
+(define (file-serve-response fname file-path req)
+  (file-serve-or-dir-response fname file-path req
+			      directory-index-serve-response))
+
+(define (tag->alt tag)
+  (case tag
+    ((directory) "[DIR]")
+    ((text) "[TXT]")
+    ((doc) "[DOC]")
+    ((image) "[IMG]")
+    ((movie) "[MVI]")
+    ((audio) "[AU ]")
+    ((archive) "[TAR]")
+    ((compressed) "[ZIP]")
+    ((uu) "[UU ]")
+    ((binhex) "[HQX]")
+    ((binary) "[BIN]")
+    (else "[   ]")))
+
+;; These icons can, for example, be found in the cern-httpd-3.0
+;; distribution at http://www.w3.org/pub/WWW/Daemon/
+
+(define (tag->icon tag)
+  (case tag
+    ((directory) "directory.xbm")
+    ((text) "text.xbm")
+    ((doc) "doc.xbm")
+    ((image) "image.xbm")
+    ((movie) "movie.xbm")
+    ((audio) "sound.xbm")
+    ((archive) "tar.xbm")
+    ((compressed) "compressed.xbm")
+    ((uu) "uu.xbm")
+    ((binhex) "binhex.xbm")
+    ((binary) "binary.xbm")
+    ((blank) "blank.xbm")
+    ((back) "back.xbm")
+    (else "unknown.xbm")))
+ 
+(define (file-extension->tag fname)
+  (let ((ext (file-name-extension fname)))
+    (cond 
+     ((string-ci=? ext ".txt") 'text)
+     ((or (string-ci=? ext ".doc")
+	  (string-ci=? ext ".htm")
+	  (string-ci=? ext ".html")
+	  (string-ci=? ext ".rtf")
+	  (string-ci=? ext ".pdf")
+	  (string-ci=? ext ".dvi")
+	  (string-ci=? ext ".ps")
+	  (string-ci=? ext ".tex")) 'doc)
+     ((or (string-ci=? ext ".bmp")
+	  (string-ci=? ext ".gif")
+	  (string-ci=? ext ".png")
+	  (string-ci=? ext ".jpg")
+	  (string-ci=? ext ".jpeg")
+	  (string-ci=? ext ".tiff")
+	  (string-ci=? ext ".tif")) 'image)
+     ((or (string-ci=? ext ".mpeg")
+	  (string-ci=? ext ".mpg")) 'movie)
+     ((or (string-ci=? ext ".au")
+	  (string-ci=? ext ".snd")
+	  (string-ci=? ext ".mp3")
+	  (string-ci=? ext ".wav")) 'audio)
+     ((or (string-ci=? ext ".tar")
+	  (string-ci=? ext ".zip")
+	  (string-ci=? ext ".zoo")) 'archive)
+     ((or (string-ci=? ext ".gz")
+	  (string-ci=? ext ".Z")
+	  (string-ci=? ext ".z")) 'compressed)
+     ((string-ci=? ext ".uu") 'uu)
+     ((string-ci=? ext ".hqx") 'binhex)
+     (else 'binary))))
+
+(define (file-tag fname type)
+  (case type
+    ((regular fifo socket) (file-extension->tag fname))
+    ((directory) 'directory)
+    (else 'unknown)))
+
+(define (time->directory-index-date-string time)
+  (format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
+
+(define (read-max-lines fname max)
+  (call-with-input-file
+      fname
+    (lambda (port)
+      (let loop ((r "") (i max))
+	(if (zero? i)
+	    r
+	    (let ((line (read-line port)))
+	      (if (eof-object? line)
+		  r
+		  (loop (string-append r " " line) (- i 1)))))))))
+
+(define (string-cut s n)
+  (if (>= (string-length s) n)
+      (substring s 0 n)
+      s))
+
+(define html-file-header
+  (let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
+	(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
+    (lambda (fname n)
+      (let ((stuff (read-max-lines fname 10)))
+	(cond
+	 ((regexp-exec title-tag-regexp stuff)
+	  => (lambda (open-match)
+	       (cond
+		((regexp-exec title-close-tag-regexp stuff
+			      (match:end open-match 0))
+		 => (lambda (close-match)
+		      (string-cut (substring stuff
+					     (match:end open-match 0)
+					     (match:start close-match 0))
+				  n)))
+		(else (string-cut (substring stuff
+					     (match:end open-match 0)
+					     (string-length stuff))
+				  n)))))
+	 (else ""))))))
+
+(define (file-documentation fname n)
+  (cond
+   ((file-extension->content-type fname)
+    => (lambda (content-type)
+	 (if (and (string=? content-type "text/html" )
+		  (file-readable? fname))
+	     (html-file-header fname n)
+	     "")))
+   (else "")))
+
+(define (directory-index req dir icon-name port)
+  
+  (define (pad-file-name file)
+    (write-string (make-string (max (- 21 (string-length file))
+				    1)
+			       #\space)
+		  port))
+  
+  (define (emit-file-name file)
+    (let ((l (string-length file)))
+      (if (<= l 20)
+	  (emit-text file port)
+	  (emit-text (substring file 0 20) port))))
+  
+  (define (index-entry file)
+    (let* ((fname (directory-as-file-name (string-append dir file)))
+	   (info (file-info fname #t))
+	   (type (file-info:type info))
+	   (size (file-info:size info))
+	   (tag (file-tag file type)))
+      (emit-tag port 'img
+		(cons 'src (icon-name tag))
+		(cons 'alt (tag->alt tag)))
+      (with-tag port a ((href file))
+	(emit-file-name file))
+      (pad-file-name file)
+      (emit-text (time->directory-index-date-string (file-info:mtime info)) port)
+      (if size
+	  (let* ((size-string
+		  (string-append (number->string (quotient size 1024))
+				 "K"))
+		 (size-string
+		  (if (<= (string-length size-string) 7)
+		      size-string
+		      (string-append (number->string (quotient size (* 1024 1024)))
+				     "M")))
+		 (size-string
+		  (if (<= (string-length size-string) 8)
+		      (string-append
+		       (make-string (- 8 (string-length size-string)) #\space)
+		       size-string)
+		      size-string)))
+	    (write-string size-string port))
+	  (write-string (make-string 8 #\space) port))
+      (write-char #\space port)
+      (emit-text (file-documentation fname 24) port)
+      (write-crlf port)))
+
+  (let ((files (directory-files dir)))
+    (for-each index-entry files)
+    (length files)))
+
+(define (directory-serve-response fname file-path req)
+  (let ((request-method (request:method req)))
+    (cond
+     ((or (string=? request-method "GET")
+	  (string=? request-method "HEAD"))
+	  
+      (if (not (eq? 'directory 
+		    (file-info:type (file-info fname #t))))
+	  (make-http-error-response http-status/forbidden req)
+	  (make-response
+	   http-status/ok
+	   (status-code->text http-status/ok)
+	   (time)
+	   "text/html"
+	   '()
+	   (make-writer-body
+	    (lambda (port options)
+	      (let* ((icon-option (httpd-options-icon-name options))
+		     (icon-name
+		      (cond
+		       ((procedure? icon-option) icon-option)
+		       ((string? icon-option)
+			(lambda (tag)
+			  (string-append icon-option (tag->icon tag))))
+		       (else tag->icon))))
+		(with-tag port html ()
+		  (let ((title (string-append "Index of /"
+					      (string-join file-path "/"))))
+		    (with-tag port head ()
+		      (emit-title port title))
+		    (with-tag port body ()
+		      (emit-header port 1 title)
+		      (with-tag port pre ()
+			(emit-tag port 'img
+				  (cons 'src (icon-name 'blank))
+				  (cons 'alt "     "))
+			(write-string "Name                 " port)
+			(write-string "Last modified          " port)
+			(write-string "Size   " port)
+			(write-string "Description" port)
+			(emit-tag port 'hr)
+			(emit-tag port 'img
+				  (cons 'src (icon-name 'back))
+				  (cons 'alt "[UP ]"))
+			(if (not (null? file-path))
+			    (begin
+			      (with-tag port a ((href ".."))
+				(write-string "Parent directory" port))
+			      (write-crlf port)))
+			(let ((n-files (directory-index req fname icon-name port)))
+			  (emit-tag port 'hr)
+			  (format port "~d files" n-files))))))))))))
+     (else
+      (make-http-error-response http-status/method-not-allowed req 
+				request-method)))))
+
+(define (index-or-directory-serve-response fname file-path req)
+  (let ((index-fname (string-append fname "index.html")))
+    (if (file-readable? index-fname)
+	(file-serve-response index-fname file-path req)
+	(directory-serve-response fname file-path req))))
+  
+(define (file-serve-and-dir-response fname file-path req)
+  (file-serve-or-dir-response fname file-path req
+			      index-or-directory-serve-response))
+
+;;; Look up user's home directory, generating an HTTP error response if you lose.
+
+(define (http-homedir username req)
+  (with-fatal-error-handler (lambda (c decline)
+			      (apply http-error http-status/bad-request req
+				     "Couldn't find user's home directory."
+				     (condition-stuff c)))
+
+    (home-dir username)))
+
+
+(define (send-file-response filename info req)
+  (if (file-not-readable? filename)	; #### double stats are no good
+      (make-http-error-response http-status/not-found req)
+      (receive (stripped-filename content-encoding)
+	  (file-extension->content-encoding filename)
+	(make-response http-status/ok
+		       (status-code->text http-status/ok)
+		       (time)
+		       (file-extension->content-type stripped-filename)
+		       (append (if content-encoding
+				   (cons 'content-encoding content-encoding)
+				   '())
+			       (list
+				(cons 'last-modified
+				      (time->http-date-string
+				       (file-info:mtime info)))
+				(cons 'content-length (file-info:size info))))
+		       (make-writer-body
+			(lambda (port options)
+			  (call-with-input-file filename
+			    (lambda (in)
+			      (copy-inport->outport in port)))))))))
+
+
+(define (file-extension->content-type fname)
+  (let ((ext (file-name-extension fname)))
+    (cond
+     ((string-ci=? ext ".htm")		"text/html")
+     ((string-ci=? ext ".html")		"text/html")
+     ((string-ci=? ext ".txt")       	"text/plain")
+     ((string-ci=? ext ".doc")       	"application/msword")
+     ((string-ci=? ext ".gif")		"image/gif")
+     ((string-ci=? ext ".png")		"image/png")
+     ((string-ci=? ext ".bmp")		"image/bmp")
+     ((or (string-ci=? ext ".jpg")
+	  (string-ci=? ext ".jpeg"))	"image/jpeg")
+     ((or (string-ci=? ext ".tiff")
+	  (string-ci=? ext ".tif"))	"image/tif")
+     ((string-ci=? ext ".rtf")		"text/rtf")
+     ((or (string-ci=? ext ".mpeg")
+	  (string-ci=? ext ".mpg"))	"video/mpeg")
+     ((or (string-ci=? ext ".au")
+	  (string-ci=? ext ".snd"))	"audio/basic")
+     ((string-ci=? ext ".wav")		"audio/x-wav")
+     ((string-ci=? ext ".dvi")		"application/x-dvi")
+     ((or (string-ci=? ext ".tex")
+	  (string-ci=? ext ".latex"))	"application/latex")
+     ((string-ci=? ext ".zip")		"application/zip")
+     ((string-ci=? ext ".tar")		"application/tar")
+     ((string-ci=? ext ".hqx")		"application/mac-binhex40")
+     ((string-ci=? ext ".ps") 		"application/postscript")
+     ((string-ci=? ext ".pdf")		"application/pdf")
+     (else               		"application/octet-stream"))))
+
+(define (file-extension->content-encoding fname)
+  (cond
+   ((let ((ext (file-name-extension fname)))
+      (cond 
+       ((string-ci=? ext ".Z")           "x-compress")
+       ((string-ci=? ext ".gz")          "x-gzip")
+       (else #f)))
+    => (lambda (encoding)
+	 (values (file-name-sans-extension fname) encoding)))
+   (else (values fname #f))))
+   

scheme/httpd/handle-fatal-error.scm

@@ -1,44 +1,10 @@
-;;; Error stuff for the http server. -*- Scheme -*-
+;;; Handle fatal errors in a sensible way. -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
 ;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; An http error condition is a data structure with the following pieces:
-;;;     (error-code request message . irritants)
-;;; You recognise one with HTTP-ERROR?, and retrieve the pieces with
-;;; CONDITION-STUFF.
-;;;
-;;; You can find out more about the Scheme 48 condition system by consulting
-;;; s48-error.txt, where I scribbled some notes as I was browsing the source
-;;; code when I wrote this file.
-
-;;; ,open conditions signals handle
-
-;;; HTTP error condition
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Define a sub-type of the S48 error condition, the HTTP error condition.
-;;; An HTTP error is one that corresponds to one of the HTTP error reply
-;;; codes, so you can reliably use an HTTP error condition to construct an
-;;; error reply message to send back to the HTTP client.
-
-(define-condition-type 'http-error '(error))
-
-(define http-error? (condition-predicate 'http-error))
-
-(define (http-error error-code req . args)
-  (apply signal 'http-error error-code req args))
-
-;;; Syntax error condition
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Scheme 48 has a "syntax error" error condition, but it isn't an error
-;;; condition! It's a warning condition. I don't understand this. 
-;;; We define a *fatal* syntax error here for the parsers to use.
-
-(define-condition-type 'fatal-syntax-error '(error))
-
-(define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
-
-(define (fatal-syntax-error msg . irritants)
-  (apply signal 'fatal-syntax-error msg irritants))
-
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; (with-fatal-error-handler* handler thunk)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

scheme/httpd/handlers.scm

@@ -0,0 +1,94 @@
+;;; http server in the Scheme Shell	-*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers.
+;;; Copyright (c) 1996-2002 by Mike Sperber.
+;;; Copyright (c) 2002 by Andreas Bernauer.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; Path handlers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Path handlers are the guys that actually perform the requested operation
+;;; on the URL. The handler interface is 
+;;;     (handler path-list request)
+;;; The path-list is a URL path list that is a suffix of REQUEST's url's
+;;; path-list. Path handlers can decide how to handle an operation by
+;;; recursively keying off of the elements in path-list. 
+;;; 
+;;; The object-oriented view:
+;;; One way to look at this is to think of the request's METHOD as a
+;;; generic operation on the URL. Recursive path handlers do method 
+;;; lookup to determine how to implement a given operation on a particular
+;;; path.
+;;;
+;;; The REQUEST is a request record, as defined in httpd-core.scm, containing
+;;; the details of the client request. However, path handlers should *not*
+;;; read the request entity from, or write the reply to the request's socket.
+;;; Path-handler I/O should be done on the current i/o ports: if the handler
+;;; needs to read an entity, it should read it from (CURRENT-INPUT-PORT); when
+;;; the handler wishes to write a reply, it should write it to 
+;;; (CURRENT-OUTPUT-PORT). This makes it easy for the procedure that called
+;;; the handler to establish I/O indirections or filters if it so desires.
+
+;; general request-handler-combinator:
+;; predicate: path x request --> boolean
+;; if #t, handler is called
+;; if #f, default-handler is called
+(define (make-request-handler predicate handler default-handler)
+  (lambda (path req)
+    (if (predicate path req)
+	(handler path req)
+	(default-handler path req))))
+
+;; same as make-request-handler except that the predicate is only
+;; called with the path:
+;; predicate: path --> boolean
+(define (make-path-handler predicate handler default-handler)
+  (make-request-handler
+   (lambda (path req) (predicate path)) handler default-handler))
+
+;; selects handler according to host-field of http-request
+(define (make-host-name-handler hostname handler default-handler)
+  (make-request-handler 
+   (lambda (path req)
+     ;; we expect only one host-header-field
+     (string=? hostname (string-trim (get-header (request:headers req) 'host))))
+   handler default-handler))
+
+;; selects handler according to path-prefix
+;; if path-prefix matches, handler is called without the path-prefix
+(define (make-path-prefix-handler path-prefix handler default-handler)
+  (lambda (path req)
+    (if (string=? path-prefix (car path))
+	(handler (cdr path) req)
+	(default-handler path req))))
+
+;;; (alist-path-dispatcher handler-alist default-handler) -> handler
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This function creates a table-driven path-handler that dispatches off
+;;; of the car of the request path. The handler uses the car to index into
+;;; a path-handler alist. If it finds a hit, it recurses using the table's
+;;; path-handler. If no hits, it handles the path with a default handler.
+;;; An alist handler is passed the tail of the original path; the
+;;; default handler gets the entire original path.
+;;;
+;;; This procedure is how you say: "If the first element of the URL's
+;;; path is 'foo', do X; if it's 'bar', do Y; otherwise, do Z." 
+
+(define (alist-path-dispatcher handler-alist default-handler)
+  (fold-right 
+   (lambda (handler-pair default-handler)
+     (make-path-prefix-handler
+      (car handler-pair)
+      (cdr handler-pair)
+      default-handler))
+   default-handler
+   handler-alist))
+
+;;; The null path handler -- handles nothing, sends back an error response.
+;;; Can be useful as the default in table-driven path handlers.
+
+(define (null-path-handler path req)
+  (make-http-error-response http-status/not-found req))

scheme/httpd/http-top.scm

@@ -1,16 +1,14 @@
-;;; Scheme Underground Web Server -*- Scheme -*-
-;;; Olin Shivers
+;;; Scheme Untergrund Web Server -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; This file contains a few example top-level path-handlers and
 ;;; other useful fragments.
 
-;;; We import procedures from these structures:
-;;; httpd-core 
-;;; cgi-server-package
-;;; httpd-basic-handlers
-;;; seval-handler-package
-
-
 ;;; - /h/<user>/<file-path> => serve <file-path> from ~user/public_html.
 ;;; - /seval  You may POST Scheme code to this URL, and receive the output.
 ;;; - Otherwise, serve files from the standard HTTP demon repository.
@@ -52,7 +50,10 @@
 ;;; env before starting.
 
 (define (httpd1)
-  (set-gid -2)  ; Should be (set-uid (->uid "nobody")) 
-  (set-uid -2)	; but NeXTSTEP loses. 
+  (set-gid (->uid "nobody"))
+  (set-uid (->gid "nobody"))
   (initialise-request-invariant-cgi-env)
-  (httpd ph 8001 "/usr/local/etc/httpd/htdocs"))
+  (httpd (make-httpd-options with-path-handler ph
+			     with-port 8001
+			     with-root-directory "/usr/local/etc/httpd/htdocs")))
+

scheme/httpd/info-gateway.scm

@@ -1,6 +1,11 @@
 ;;; GNU info -> HTML gateway for the SU web server. -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
 ;;; Copyright (c) 1996 by Mike Sperber.
 ;;; based on code with the same purpose by Gaebe Engelhart
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 
 ;;; (info-handler parse-info reference find-icon address) -> handler
@@ -129,39 +134,46 @@
 	     (string-append "info?" node-name))))))
 
     (lambda (path req)
-      (switch string=? (request:method req)
-	(("GET")
-	 (with-fatal-error-handler
-	  (lambda (c decline)
-	    (cond
-	     ((info-gateway-error? c)
-	      (apply http-error http-reply/internal-error req
-		     (condition-stuff c)))
-	     ((http-error? c)
-	      (apply http-error (car (condition-stuff c)) req
-		     (cddr (condition-stuff c))))
-	     (else
-	      (decline))))
+      (let ((request-method (request:method req)))
+	(cond 
+	 ((string=? request-method "GET")
+	  (with-fatal-error-handler
+	   (lambda (c decline)
+	     (cond
+	      ((info-gateway-error? c)
+	       (apply http-error http-status/bad-gateway req
+		      (condition-stuff c)))
+	      ((http-error? c)
+	       (apply http-error (car (condition-stuff c)) req
+		      (cddr (condition-stuff c))))
+	      (else
+	       (decline))))
 
-	  (if (not (v0.9-request? req))
-	      (begin
-		(begin-http-header #t http-reply/ok)
-		(write-string "Content-type: text/html\r\n")
-		(write-string "\r\n")))
+	   (make-response
+	    http-status/ok
+	    (status-code->text http-status/ok)
+	    (time)
+	    "text/html"
+	    '()
+	    (make-writer-body
+	     (lambda (out options)
+	   
+	       (receive (find-entry node-name) (parse-info-url (request:url req))
+		 (display-node node-name
+			       (file-finder find-entry)
+			       (referencer make-reference (request:url req) out)
+			       icon-name
+			       out))
+	       (with-tag out address ()
+		 (write-string address out)))))))
 
-	  (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))
-			  icon-name))
-
-	  (with-tag #t address ()
-	    (write-string address))))
-	(else (http-error http-reply/method-not-allowed req))))))
+	 (else 
+	  (make-http-error-response http-status/method-not-allowed req 
+				    request-method)))))))
 
 (define split-header-line
-  (let ((split (infix-splitter "(, *)|(  +)|( *\t *)"))
-	(split-field (infix-splitter ": *")))
+  (let ((split (infix-splitter (make-regexp "(, *)|(  +)|( *\t *)")))
+	(split-field (infix-splitter (make-regexp ": *"))))
     (lambda (l)
       (let ((fields (map split-field (split l))))
 	  
@@ -213,23 +225,23 @@
 			     (values file node))
       (string-append "(" file ")" node))))
 
-(define (display-icon file alt)
-  (emit-tag #t 'img
+(define (display-icon file alt out)
+  (emit-tag out 'img
     (cons 'src file)
     (cons 'alt alt)
     (cons 'align "bottom")))
 	 
-(define (referencer make-reference old-entry)
+(define (referencer make-reference old-entry out)
   (lambda (file node-name label . maybe-icon)
     (receive (node-file node) (parse-node-name node-name)
       (let ((file (or node-file file)))
-	(with-tag #t a ((href (make-reference
-			       old-entry
-			       (escape-uri (unparse-node-name file node)))))
+	(with-tag out a ((href (make-reference
+				old-entry
+				(escape-uri (unparse-node-name file node)))))
 	  (if (and (not (null? maybe-icon))
 		   (car maybe-icon))
-	      (display-icon (car maybe-icon) (cadr maybe-icon)))
-	  (emit-text label))))))
+	      (display-icon (car maybe-icon) (cadr maybe-icon) out))
+	  (emit-text label out))))))
 
 (define node-prologue (ascii->char 31))
 (define node-epilogue-regexp
@@ -250,30 +262,30 @@
 ;; Document title
 
 (define (display-title file node up previous next
-		       display-reference icon-name)
+		       display-reference icon-name out)
 
   (define (maybe-display-header header icon alt)
     (if header
 	(begin
-	  (newline)
-	  (with-tag #t b ()
+	  (newline out)
+	  (with-tag out b ()
 	    (display-reference file header header icon alt)))))
 
-  (emit-title #t (string-append "Info Node: "
+  (emit-title out (string-append "Info Node: "
 				(unparse-node-name file node)))
-  (with-tag #t h1 ()
-	    (emit-tag #t 'img
+  (with-tag out h1 ()
+	    (emit-tag out 'img
 		      (cons 'src (icon-name 'info))
 		      (cons 'alt "Info Node")
 		      (cons 'align 'bottom))
-	    (write-string (unparse-node-name file node)))
-  (emit-tag #t 'hr)
+	    (write-string (unparse-node-name file node) out))
+  (emit-tag out 'hr)
   (maybe-display-header next (icon-name 'next) "[Next]")
   (maybe-display-header previous (icon-name 'previous) "[Previous]")
   (maybe-display-header up (icon-name 'up) "[Up]")
 	 
   (if (or next previous up)
-      (emit-tag #t 'hr)))
+      (emit-tag out 'hr)))
 
 ;; Text
 
@@ -305,32 +317,32 @@
 		    (loop (string-append line cr new-line) (- count 1))))))))))
 		    
 
-(define (display-xref xref file display-reference)
+(define (display-xref xref file display-reference out)
   (let* ((match (regexp-exec xref-regexp xref))
 	 (note (match:substring match 1))
 	 (node-name (match:substring match 2))
 	 (node-name (if (string=? "" node-name) note node-name))
 	 (node-name (substring node-name
-			       (skip-whitespace node-name)
+			       (string-skip node-name char-set:whitespace)
 			       (string-length node-name))))
-    (emit-text "See ")
+    (emit-text "See " out)
     (display-reference file node-name note)))
 
 (define display-text
   (let ((split-xrefs (infix-splitter xref-regexp #f 'split)))
-    (lambda (line port file display-reference)
+    (lambda (line port file display-reference out)
       (let* ((line (complete-line line port))
 	     (components (split-xrefs line)))
 	;; in components, every 2nd element is a cross reference
 	;; also, it always has odd length or length zero
 	(if (not (null? components))
 	    (let loop ((components components))
-	      (emit-text (car components))
+	      (emit-text (car components) out)
 	      (if (not (null? (cdr components)))
 		  (begin
-		    (display-xref (cadr components) file display-reference)
+		    (display-xref (cadr components) file display-reference out)
 		    (loop (cddr components))))))
-	(newline)))))
+	(newline out)))))
 
 ;; Menus
 
@@ -339,7 +351,7 @@
 
 (define (char-splitter c)
   (lambda (s)
-    (cond ((index s c)
+    (cond ((string-index s c)
 	   => (lambda (i)
 		(values (substring s 0 i)
 			(substring s (+ 1 i) (string-length s)))))
@@ -347,7 +359,7 @@
 
 (define colon-split (char-splitter #\:))
 
-(define (display-menu-item-header line port file display-reference icon-name)
+(define (display-menu-item-header line port file display-reference icon-name out)
   (let ((menu-line-split (infix-splitter menu-item-regexp)))
     (receive (note rest) (colon-split (cadr (menu-line-split line)))
       (receive (node-name text)
@@ -361,24 +373,24 @@
 			 (match:substring match 2))))
 	   (else
 	    (info-gateway-error  "invalid menu item")))
-	(emit-tag #t 'dt)
+	(emit-tag out 'dt)
 	(display-reference file node-name note (icon-name 'menu) "*")
-	(newline)
+	(newline out)
 	(if (and (not (string=? "" text))
 		 (not (string=? "." text)))
 	    (begin
-	      (emit-tag #t 'dd)
-	      (display-text text port file display-reference)))))))
+	      (emit-tag out 'dd)
+	      (display-text text port file display-reference out)))))))
 
-(define (display-menu line port file display-reference icon-name)
-  (emit-close-tag #t 'pre)
+(define (display-menu line port file display-reference icon-name out)
+  (emit-close-tag out 'pre)
     
-  (with-tag #t dl ()
+  (with-tag out dl ()
     (let loop ((line line))
       (if (eof-object? line)
 	  (info-gateway-error "unexpected end of info file"))
 
-      (display-menu-item-header line port file display-reference icon-name)
+      (display-menu-item-header line port file display-reference icon-name out)
 
       (let finish-item-loop ()
 	(if (eof-object? line)
@@ -389,45 +401,46 @@
 	   ((or (eof-object? line)
 		(node-epilogue? line)
 		(string=? "" line))
-	    (emit-tag #t 'pre)
-	    (dispatch-line line port file display-reference icon-name))
+	    (emit-tag out 'pre)
+	    (dispatch-line line port file display-reference icon-name out))
 	   ((regexp-exec menu-item-regexp line)
 	    (loop line))
 	   (else
-	    (display-text line port file display-reference)
+	    (display-text line port file display-reference out)
 	    (finish-item-loop))))))))
 
 ;; Central dispatch
 
-(define (dispatch-line line port file display-reference icon-name)
+(define (dispatch-line line port file display-reference icon-name out)
   (cond
    ((or (eof-object? line) (node-epilogue? line)) #f)
-   ((string=? "" line) (emit-p #t) #t)
+   ((string=? "" line) (emit-p out) #t)
    ((regexp-exec menu-regexp line) #t) ;; this should probably be expanded
    ((regexp-exec menu-item-regexp line)
-    (display-menu line port file display-reference icon-name))
+    (display-menu line port file display-reference icon-name out))
    (else
-    (display-text line port file display-reference) #t)))
+    (display-text line port file display-reference out) #t)))
 
-(define (display-body port file display-reference icon-name)
+(define (display-body port file display-reference icon-name out)
   (let loop ()
     (let ((line (read-line port)))
-      (if (dispatch-line line port file display-reference icon-name)
+      (if (dispatch-line line port file display-reference icon-name out)
 	  (loop)))))
 	    
-(define (display-node node-name find-file display-reference icon-name)
+(define (display-node node-name find-file display-reference icon-name out)
   (receive (file node) (parse-node-name node-name)
     (receive (port file-header node-header up-header prev-header next-header)
 	(find-node file node find-file)
     
-      (with-tag #t html ()
-	(with-tag #t head ()
+      (with-tag out html ()
+	(with-tag out head ()
 	  (display-title file node-header up-header
 			 prev-header next-header
-			 display-reference icon-name))
-	(with-tag #t body ()
-	  (with-tag #t pre ()
-	    (display-body port file display-reference icon-name))))
+			 display-reference icon-name
+			 out))
+	(with-tag out body ()
+	  (with-tag out pre ()
+	    (display-body port file display-reference icon-name out))))
       
       (close-input-port port))))
 
@@ -450,7 +463,7 @@
 (define (ensure-indirect-tag-table-header port)
   (ensure-regexp-line port "^\\(Indirect\\)" "no indirect tag"))
 
-(define split-indirection (infix-splitter " *: *"))
+(define split-indirection (infix-splitter (make-regexp " *: *")))
 (define (parse-indirection line)
   (let ((l (split-indirection line)))
     (if (null? (cdr l))
@@ -473,10 +486,10 @@
 (define tag-seek-separator (ascii->char 127))
 
 (define parse-tag
-  (let ((split (infix-splitter ", *"))
+  (let ((split (infix-splitter (make-regexp ", *")))
 	(split-field (infix-splitter ": "))
 	(split-node-info
-	 (infix-splitter (regexp-quote (string tag-seek-separator)))))
+	 (infix-splitter (string tag-seek-separator))))
 
     (define (barf)
       (info-gateway-error "invalid tag entry in info file"))
@@ -507,7 +520,7 @@
       (if (eof-object? line)
 	  (info-gateway-error "invalid info file"))
       (if (regexp-exec node-epilogue-regexp line)
-	  (http-error http-reply/not-found #f "node not found"))
+	  (http-error http-status/not-found #f "node not found"))
       (receive (entry-node file seek) (parse-tag line)
         (if (string=? node entry-node)
 	    (cons file seek)
@@ -516,7 +529,7 @@
 (define (find-indirection-entry seek-pos indirection-table)
   (let loop ((table indirection-table))
     (if (null? table)
-	(http-error http-reply/not-found #f "node not found"))
+	(http-error http-status/not-found #f "node not found"))
     (let* ((entry (car table))
 	   (pos (cdr entry)))
       (if (and (>= seek-pos pos)
@@ -560,7 +573,7 @@
 
 (define (find-node file node find-file)
   (if (not file)
-      (http-error http-reply/not-found #f
+      (http-error http-status/not-found #f
 		  "no file in info node specification"))
 
   (let* ((fname (find-file file))
@@ -568,7 +581,7 @@
     (let loop ((port port))
       (let ((line (read-line port)))
 	(if (eof-object? line)
-	    (http-error http-reply/not-found #f "info node not found"))
+	    (http-error http-status/not-found #f "info node not found"))
 	(if (node-prologue? line)
 	    (let ((header (read-line port)))
 	      (if (eof-object? header)
@@ -611,7 +624,7 @@
 		   => (lambda (match)
 			(match:substring match 1)))
 		  (else base)))
-	   (base-ci (downcase-string base))
+	   (base-ci (string-map char-downcase base))
 	   (alts-1 (if (string=? base base-ci)
 		       (list base)
 		       (list base base-ci)))
@@ -631,7 +644,7 @@
   (let ((alts (info-file-alternative-names file)))
     (let path-loop ((path info-path))
       (if (null? path)
-	  (http-error http-reply/not-found #f "info file not found"))
+	  (http-error http-status/not-found #f "info file not found"))
       (let alt-loop ((alts alts))
 	(if (null? alts)
 	    (path-loop (cdr path))

scheme/httpd/logging.scm

@@ -0,0 +1,169 @@
+;;; logging.scm
+;;; logging functionality for web server
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 2002 by Martin Gasbichler.
+;;; Copyright (c) 2002 by Andreas Bernauer.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+(define do-nothing-proc (lambda a #f))
+(define-record logging
+  (http-log-port #f)			;port to perform CLF-logging
+  (http-log-proc do-nothing-proc)	;proc to run for CLF-logging (req status-code)
+  (http-syslog? #f)			;do syslogging?
+  (http-syslog-proc do-nothing-proc)	;proc to run for syslog (level fmt . args)
+  (dns-lookup? #f))			;perform dns-lookups?
+
+(define logging (make-preserved-thread-fluid #f))
+
+(define (make-fluid-selector selector)
+  (lambda () (selector (thread-fluid logging))))
+
+(define (make-fluid-setter setter)
+  (lambda (value)
+    (setter (thread-fluid logging) value)))
+
+(define logging-http-log-proc (make-fluid-selector logging:http-log-proc))
+(define logging-http-syslog-proc (make-fluid-selector logging:http-syslog-proc))
+(define logging-http-syslog? (make-fluid-selector logging:http-syslog?))
+(define logging-http-log-port (make-fluid-selector logging:http-log-port))
+(define logging-dns-lookup? (make-fluid-selector logging:dns-lookup?))
+
+(define set-logging-http-log-proc (make-fluid-setter set-logging:http-log-proc))
+(define set-logging-http-syslog-proc (make-fluid-setter set-logging:http-syslog-proc))
+(define set-logging-http-syslog? (make-fluid-setter set-logging:http-syslog?))
+(define set-logging-http-log-port (make-fluid-setter set-logging:http-log-port))
+(define set-logging-dns-lookup? (make-fluid-setter set-logging:dns-lookup?))
+
+(define http-syslog
+  (lambda a
+    (apply (logging-http-syslog-proc) a)))
+
+(define http-log
+  (lambda a
+    (apply (logging-http-log-proc) a)))
+
+(define (http-syslog?)
+  (logging-http-syslog?))
+
+(define (init-http-log! options)
+  ;; syslog has to be initialized before CLF-logging
+  ;; because the latter may generate syslog-messages
+  (init-http-syslog! (httpd-options-syslog? options))
+  (init-http-port-log! (httpd-options-logfile options))
+  (if (httpd-options-resolve-ips? options)
+      (set-logging-dns-lookup? #t)
+      (set-logging-dns-lookup? #f)))
+
+(define (init-http-syslog! syslog?)
+  (if syslog?
+      (let ((http-syslog-lock (make-lock)))
+	(set-logging-http-syslog? #t)
+	(set-logging-http-syslog-proc
+	      (lambda (level fmt . args)
+		(obtain-lock http-syslog-lock)
+		(syslog level
+			(apply format #f fmt args))
+		(release-lock http-syslog-lock))))
+      (begin
+	(set-logging-http-syslog? #f)
+	(set-logging-http-syslog-proc do-nothing-proc))))
+
+(define (init-http-port-log! logfile)
+  (let ((logport 
+	 (cond
+	  ((string? logfile)            ; try to open logfile for appending (output)
+	   (open-logfile logfile))
+	  ((output-port? logfile)       ; we were given an output port, so let's use it
+	   logfile)
+	  ((eq? logfile #f)             ; no logging demanded
+	   #f)
+	; unexpected value of logfile; 
+	  (else
+	   (http-syslog 
+	    (syslog-level warning)
+	    "[httpd] Warning: Logfile was not specified correctly (given: ~S).~% No CLF logging."
+	    logfile)
+	   (make-null-output-port)))))
+
+    (if logfile                         ; if logging was specified, set up the logger
+	(let ((http-log-lock (make-lock)))
+	  (set-logging-http-log-port logport)
+	  (if (string? logfile)
+	      (spawn (make-logfile-rotator logfile http-log-lock)))
+	  (set-logging-http-log-proc (make-http-log-proc http-log-lock))))))
+	
+(define (make-http-log-proc http-log-lock)
+  (lambda (req status-code)
+    (if req
+	(begin
+	  (obtain-lock http-log-lock)
+	  (display (make-CLF
+		    (receive (host-address _) 
+			(socket-address->internet-address 
+			 (socket-remote-address (request:socket req)))
+		      (format-internet-host-address host-address))
+		    (request:method req) ; request method
+		    (uri-path-list->path 
+		     (http-url:path (request:url req)))	; requested file
+		    (version->string (request:version req)) ; protocol version
+		    status-code
+		    23			; filesize (unknown)
+		    (get-header (request:headers req) 'referer)
+		    (get-header (request:headers req) 'user-agent))
+		   (logging-http-log-port))
+	  (force-output (logging-http-log-port))
+	  (release-lock http-log-lock)))))
+
+
+;; does the logfile rotation on signal USR1
+(define (make-logfile-rotator logfile http-log-lock)
+  (set-interrupt-handler interrupt/usr1 #f)
+  (lambda ()
+    (on-interrupt
+     interrupt/usr1
+     (lambda ()
+       (obtain-lock http-log-lock)
+       (close-output-port (logging-http-log-port))
+       (set-logging-http-log-port (open-logfile logfile))
+       (release-lock http-log-lock)))))
+
+(define (open-logfile logfile)	      
+  (with-errno-handler*
+   (lambda (errno packet)
+     (http-syslog (syslog-level warning)
+		  "[httpd] Warning: An error occured while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
+	     logfile
+	     (car packet))
+     (make-null-output-port))
+   (lambda ()
+     (open-output-file logfile 
+		       (bitwise-ior open/create open/append)))))
+
+; returns a string for a CLF entry (Common Log Format)
+; note: till now, we do not log the user's time zone code
+(define (make-CLF remote-ip request-type requested-file protocol http-code filesize referer user-agent)
+  (format #f "~A - - ~A ~S ~A ~A ~S ~S~%"
+		(or (maybe-dns-lookup remote-ip) "-")
+		(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date))     ; +0000 as we don't know
+		(string-join (list request-type 
+				   (string-append "/" requested-file) 
+				   protocol))
+		; Unfortunately, we first split the request line into 
+		; method/request-type etc. and put it together here.
+		; Files conform to CLF are expected to print the original line.
+		(or http-code "-")
+		(or filesize "-")
+		(if (string? referer) (string-trim referer) "")
+		(if (string? user-agent) 
+		    (string-trim user-agent char-set:whitespace) 
+		    "")))
+
+
+(define (maybe-dns-lookup remote-ip)
+  (if (logging-dns-lookup?)
+      (or (dns-lookup-ip remote-ip)
+	  remote-ip)
+      remote-ip))

scheme/httpd/options.scm

@@ -0,0 +1,138 @@
+;;; http server in the Scheme Shell	-*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 2002 by Mike Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; This package manages options to the http server as an abstract
+;;; data type.
+
+(define-record-type httpd-options :httpd-options
+  (really-make-httpd-options port
+			     root-directory
+			     icon-name
+			     fqdn
+			     reported-port
+			     path-handler
+			     server-admin
+			     simultaneous-requests
+			     logfile
+			     syslog?
+			     resolve-ips?)
+  httpd-options?
+  (port httpd-options-port
+	set-httpd-options-port!)
+  (root-directory httpd-options-root-directory
+		  set-httpd-options-root-directory!)
+  ;; ICON-NAME specifies how to generate the links to
+  ;; various decorative icons for the listings.  It can either be a
+  ;; procedure which gets passed one of the icon tags in TAG->ICON and
+  ;; is expected to return a link pointing to the icon.  If it is a
+  ;; string, that is taken as prefix to which the names from TAG->ICON
+  ;; are appended.
+  (icon-name httpd-options-icon-name
+	     set-httpd-options-icon-name!)
+  (fqdn httpd-options-fqdn
+	set-httpd-options-fqdn!)
+  (reported-port httpd-options-reported-port
+		 set-httpd-options-reported-port!)
+  (path-handler httpd-options-path-handler
+		set-httpd-options-path-handler!)
+  (server-admin httpd-options-server-admin
+		set-httpd-options-server-admin!)
+  (simultaneous-requests httpd-options-simultaneous-requests
+			 set-httpd-options-simultaneous-requests!)
+  (logfile httpd-options-logfile set-httpd-options-logfile!)
+  (syslog? httpd-options-syslog? set-httpd-options-syslog?!)
+  (resolve-ips? httpd-options-resolve-ips? set-httpd-options-resolve-ips?!))
+
+; default httpd-options generation
+(define (make-default-httpd-options)
+  (really-make-httpd-options 80		; port
+			     "/"	; root-directory
+			     #f		; icon-name
+			     #f		; fqdn
+			     #f		; reported-port
+			     #f		; path-handler
+			     #f         ; server-admin
+			     #f	        ; simultaneous-requests
+			     #f
+					; string: filename of logfile (directory must exist)
+					; output-port: log to this port (e.g. (current-error-port))
+					; #f: no logging
+			     #t		; Do syslogging?
+			     #t))	; Write host names instead of IPs in logfiles?
+
+; creates a copy of a given httpd-option
+
+(define (copy-httpd-options options)
+  (let ((new-options (make-default-httpd-options)))
+    (set-httpd-options-port! new-options
+			     (httpd-options-port options))
+    (set-httpd-options-root-directory! new-options
+				       (httpd-options-root-directory options))
+    (set-httpd-options-icon-name! new-options
+				  (httpd-options-icon-name options))
+    (set-httpd-options-fqdn! new-options
+			     (httpd-options-fqdn options))
+    (set-httpd-options-reported-port! new-options
+				      (httpd-options-reported-port options))
+    (set-httpd-options-path-handler! new-options
+				     (httpd-options-path-handler options))
+    (set-httpd-options-server-admin! new-options
+				     (httpd-options-server-admin options))
+    (set-httpd-options-simultaneous-requests!
+     new-options
+     (httpd-options-simultaneous-requests options))
+    (set-httpd-options-logfile! new-options (httpd-options-logfile options))
+    (set-httpd-options-syslog?! new-options (httpd-options-syslog? options))
+    (set-httpd-options-resolve-ips?! new-options (httpd-options-resolve-ips? options))
+    new-options))
+
+; (make-httpd-options-transformer set-option!) -> lambda (new-value [httpd-option])
+; creates a transformer for httpd-options
+; the returned procedure is called with the new value for the option
+; and optionally with the httpd-option to change
+(define (make-httpd-options-transformer set-option!)
+  (lambda (new-value . stuff)
+    (let ((new-options (if (not (null? stuff))
+			   (copy-httpd-options (car stuff))
+			   (make-default-httpd-options))))
+      (set-option! new-options new-value)
+      new-options)))
+
+; several transformers for port, root-directory, etc.
+(define with-port
+  (make-httpd-options-transformer set-httpd-options-port!))
+(define with-root-directory
+  (make-httpd-options-transformer set-httpd-options-root-directory!))
+(define with-icon-name
+  (make-httpd-options-transformer set-httpd-options-icon-name!))
+(define with-fqdn
+  (make-httpd-options-transformer set-httpd-options-fqdn!))
+(define with-reported-port
+  (make-httpd-options-transformer set-httpd-options-reported-port!))
+(define with-path-handler
+  (make-httpd-options-transformer set-httpd-options-path-handler!))
+(define with-server-admin
+  (make-httpd-options-transformer set-httpd-options-server-admin!))
+(define with-simultaneous-requests
+  (make-httpd-options-transformer set-httpd-options-simultaneous-requests!))
+(define with-logfile
+  (make-httpd-options-transformer set-httpd-options-logfile!))
+(define with-syslog?
+  (make-httpd-options-transformer set-httpd-options-syslog?!))
+(define with-resolve-ips?
+  (make-httpd-options-transformer set-httpd-options-resolve-ips?!))
+
+(define (make-httpd-options . stuff)
+  (let loop ((options (make-default-httpd-options))
+	     (stuff stuff))
+    (if (null? stuff)
+	options
+	(let* ((transformer (car stuff))
+	       (value (cadr stuff)))
+	  (loop (transformer value options)
+		(cddr stuff))))))

scheme/httpd/request.scm

@@ -0,0 +1,45 @@
+;;;; HTTP request
+
+;;; This file is part of the Scheme Untergrund Networking package.
+;;; Copyright (c) 1996 by Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;;; This code defines the http REQUEST data structure
+
+(define-record request
+  method		; A string such as "GET", "PUT", etc.
+  uri			; The escaped URI string as read from request line.
+  url			; An http URL record (see url.scm).
+  version		; A (major . minor) integer pair.
+  headers		; An rfc822 header alist (see rfc822.scm).
+  socket)		; The socket connected to the client.
+
+(define-record-discloser type/request
+  (lambda (req)
+    (list 'request 
+	  (request:method req)
+	  (request:uri req)
+	  (request:url req)
+	  (request:version req)
+	  (request:headers req)
+	  (request:socket req))))
+;;; A http protocol version is an integer  pair: (major . minor).
+
+(define (version< v1 v2)
+  (or (< (car v1) (car v2))
+      (and (= (car v1) (car v2))
+	   (< (cdr v1) (cdr v2)))))
+
+(define (version<= v1 v2) (not (version< v2 v1)))
+
+(define (v0.9-request? req)
+  (version<= (request:version req) '(0 . 9)))
+
+
+(define (version->string v)
+  (string-append "HTTP/"
+		 (number->string (car v))
+		 "."
+		 (number->string (cdr v))))
+

scheme/httpd/response.scm

@@ -0,0 +1,241 @@
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
+;;; Copyright (c) 2002 by Mike Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+(define-record-type :http-response
+  (make-response code message seconds mime extras body)
+  response?
+  (code response-code)
+  (message response-message)
+  (seconds response-seconds)
+  (mime response-mime)
+  (extras response-extras)
+  (body response-body))
+
+(define-record-type :http-writer-body
+  (make-writer-body proc)
+  writer-body?
+  (proc writer-body-proc))
+
+(define-record-type :http-reader-writer-body
+  (make-reader-writer-body proc)
+  reader-writer-body?
+  (proc reader-writer-body-proc))
+
+(define-record-type :http-redirect-body
+  (make-redirect-body location)
+  redirect-body?
+  (location redirect-body-location))
+			   
+
+(define (display-http-body body iport oport options)
+  (cond
+   ((writer-body? body)
+    ((writer-body-proc body) oport options))
+   ((reader-writer-body? body)
+    ((reader-writer-body-proc body) iport oport options))))
+
+
+(define-syntax define-http-status-codes
+  (syntax-rules ()
+    ((define-http-status-codes table set (name val msg) ...)
+     (begin (define table '((val . msg) ...))
+	    (define-enum-constant set name val)
+	    ...))))
+
+(define-http-status-codes http-status-text-table http-status
+  (ok			200 "OK")
+  (created		201 "Created")
+  (accepted		202 "Accepted")
+  (prov-info		203 "Provisional Information")
+  (no-content		204 "No Content")
+
+  (mult-choice		300 "Multiple Choices")
+  (moved-perm		301 "Moved Permanently")
+  (moved-temp		302 "Moved Temporarily")
+  (method		303 "Method (obsolete)")
+  (not-mod		304 "Not Modified")
+
+  (bad-request		400 "Bad Request")
+  (unauthorized		401 "Unauthorized")
+  (payment-req		402 "Payment Required")
+  (forbidden		403 "Forbidden")
+  (not-found		404 "Not Found")
+  (method-not-allowed	405 "Method Not Allowed")
+  (none-acceptable	406 "None Acceptable")
+  (proxy-auth-required	407 "Proxy Authentication Required")
+  (timeout		408 "Request Timeout")
+  (conflict		409 "Conflict")
+  (gone			410 "Gone")
+
+  (internal-error	500 "Internal Server Error")
+  (not-implemented	501 "Not Implemented")
+  (bad-gateway		502 "Bad Gateway")
+  (service-unavailable	503 "Service Unavailable")
+  (gateway-timeout	504 "Gateway Timeout")
+  
+  (redirect             -301 "Internal redirect"))
+	
+(define (status-code->text code)
+  (cdr (assv code http-status-text-table)))
+
+;;; (make-http-error-response status-code req [message . extras])
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Take an http-error condition, and format it into a response to the client.
+;;;
+;;; As a special case, request REQ is allowed to be #f, meaning we haven't
+;;; even had a chance to parse and construct the request. This is only used
+;;; for 400 BAD-REQUEST error report.
+
+(define (make-http-error-response status-code req . args)
+  (http-log req status-code)
+
+  (let* ((message (and (pair? args) (car args)))
+	 (extras  (if (pair? args) (cdr args) '()))
+
+	 (generic-title (lambda (port)
+			  (title-html port
+				      (status-code->text status-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 status-code
+			   (status-code->text status-code)
+			   (time)
+			   "text/html"
+			   headers
+			   (make-writer-body writer-proc)))))
+
+    (cond
+     ;; This error response requires two args: message is the new URI: field,
+     ;; and the first EXTRA is the older Location: field.
+     ((or (= status-code http-status/moved-temp)
+	  (= status-code http-status/moved-perm))
+      (create-response
+       (list (cons 'uri message)
+	     (cons 'location (car extras)))
+       (lambda (port options)
+	 (title-html port "Document moved")
+	 (format port
+		 "This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
+		 (if (= status-code http-status/moved-temp) "temporarily" "permanently")
+		 message)
+	 (close-html port))))
+
+     ((= status-code http-status/bad-request)
+      (create-response
+       '()
+       (lambda (port options)
+	 (generic-title port)
+	 (write-string "<P>Client sent a query that this server could not understand.\n"
+		       port)
+	 (send-message port)
+	 (close-html port))))
+
+     ((= status-code http-status/unauthorized)
+      (create-response
+       (list (cons 'WWW-Authenticate message)) ; Vas is das? 
+       ;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47
+       ;; message should be a challenge(?)
+       (lambda (port options)
+	 (title-html port "Authorization Required")
+	 (write-string "<P>Browser not authentication-capable or\n" port)
+	 (write-string "authentication failed.\n" port)
+	 (send-message port)
+	 (close-html port))))
+
+     ((= status-code http-status/forbidden)
+      (create-response
+       '()
+       (lambda (port options)
+	 (title-html port "Request not allowed.")
+	 (format port 
+		 "Your client does not have permission to perform a ~A~%"
+		 (request:method req))
+	 (format port "operation on url ~a.~%" (request:uri req))
+	 (send-message port)
+	 (close-html port))))
+       
+     ((= status-code http-status/not-found)
+      (create-response
+       '()
+       (lambda (port options)
+	 (title-html port "URL not found")
+	 (write-string 
+	  "<P>The requested URL was not found on this server.\n"
+	  port)
+	 (send-message port)
+	 (close-html port))))
+
+     ((= status-code http-status/internal-error)
+      (http-syslog (syslog-level error) "internal-error: ~A" message)
+      (create-response
+       '()
+       (lambda (port options)
+	 (generic-title port)
+	 (format port "The server encountered an internal error or
+misconfiguration and was unable to complete your request.
+<P>
+Please inform the server administrator, ~A, of the circumstances leading to
+the error, and time it occured.~%"
+		 (httpd-options-server-admin options))
+	 (send-message port)
+	 (close-html port))))
+      
+     ((= status-code http-status/not-implemented)
+      (create-response
+       '()
+       (lambda (port options)
+	 (generic-title port)
+	 (format port "This server does not currently implement 
+the requested method (~A).~%"
+		 (request:method req))
+	 (send-message port)
+	 (close-html port))))
+
+     ((= status-code http-status/bad-gateway)
+      (create-response
+       '()
+       (lambda (port options)
+	 (generic-title port)
+	 (format port "An error occured while waiting for the 
+response of a gateway.~%")
+	 (send-message port)
+	 (close-html port))))
+
+     (else 
+      (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code)
+      (create-response
+       '()
+       (lambda (port options)
+	 (generic-title port)
+	 (send-message port)
+	 (close-html port)))))))
+
+(define (title-html out message)
+  (format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
+  (format out "<BODY>~%<H1>~A</H1>~%" message))
+
+(define (time->http-date-string time)
+  (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
+
+
+;; Creates a redirect response. The server will serve the new file indicated by
+;; NEW-LOCATION. NEW-LOCATION must be uri-encoded and begin with a slash.
+(define (make-redirect-response new-location)
+  (make-response
+   http-status/redirect
+   (status-code->text http-status/redirect)
+   (time)
+   ""
+   '()
+   (make-redirect-body new-location)))

scheme/httpd/rman-gateway.scm

@@ -0,0 +1,185 @@
+;;; man page -> HTML gateway for the SU web server. -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1996 by Mike Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; This uses RosettaMan and is currently based on version 2.5a6
+;;; (RosettaMan is based at
+;;;   ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
+
+;(define rman/rman '("/afs/wsi/rs_aix41/bin/rman" -fHTML))
+(define rman/man '(man))
+(define rman/nroff '(nroff -man))
+;(define rman/gzcat '("/afs/wsi/rs_aix41/bin/zcat"))
+;(define rman/zcat '("/afs/wsi/rs_aix41/bin/zcat"))
+(define rman/rman '("/usr/bin/rman" -fHTML))
+(define rman/gzcat '("/usr/bin/zcat"))
+(define rman/zcat '("/usr/bin/zcat"))
+
+(define (rman-handler finder referencer address . maybe-man)
+  (let ((parse-man-url
+	 (cond
+	  ((procedure? finder) finder)
+	  ((list? finder)
+	   (lambda (url)
+	     (values finder
+		     (unescape-uri (http-url:search url))
+		     '())))
+	  (else
+	   (let ((man-path ((infix-splitter ":") (getenv "MANPATH"))))
+	     (lambda (url)
+	       (values man-path
+		       (unescape-uri (http-url:search url))
+		       '()))))))
+	(reference-template
+	 (cond
+	  ((procedure? referencer) referencer)
+	  ((string? referencer) (lambda (entry section) referencer))
+	  (else (lambda (entry section) "man?%s(%s)"))))
+	(man (:optional maybe-man man)))
+
+    (lambda (path req)
+      (let ((request-method (request:method req)))
+	(cond 
+	 ((string=? request-method "GET")
+	  (with-fatal-error-handler
+	   (lambda (c decline)
+	     (cond
+	      ((http-error? c)
+	       (apply http-error (car (condition-stuff c)) req
+		      (cddr (condition-stuff c))))
+	      (else
+	       (decline))))
+	   
+	   (make-response
+	    http-status/ok
+	    (status-code->text http-status/ok)
+	    (time)
+	    "text/html"
+	    '()
+	    (make-writer-body
+	     (lambda (out options)
+	       (receive (man-path entry and-then) 
+		   (parse-man-url (request:url req))
+		 (emit-man-page entry man man-path and-then reference-template out))
+	       
+	       (with-tag out address ()
+		 (display address out)))))))
+	 (else 
+	  (make-http-error-response http-status/method-not-allowed req 
+				    request-method)))))))
+
+(define (cat-man-page key section out)
+  (let ((title (if section
+		   (format #f "~a(~a) manual page" key section)
+		   (format #f "~a manual page" key))))
+    (emit-title out title)
+    (emit-header out 1 title)
+    (newline out)
+    (with-tag out body ()
+      (with-tag out pre ()
+	(copy-inport->outport (current-input-port)
+			      out)))))
+
+(define (emit-man-page entry man man-path and-then reference-template out)
+  (receive (key section) (parse-man-entry entry)
+    (let ((status
+	   (cond
+	    ((procedure? and-then)
+	     (run (| (begin (man section key man-path))
+		     (begin (and-then key section)))
+		   (= 1 ,out)
+		   (= 2 ,out)))
+	     (else
+	      (run (| (begin (man section key man-path))
+		      (,@rman/rman ,@and-then
+				   -r ,(reference-template entry section)))
+		   (= 1 ,out)
+		   (= 2 ,out))))))
+
+      (if (not (zero? status))
+	  (error "internal error emitting man page")))))
+      
+(define parse-man-entry
+  (let ((entry-regexp (make-regexp "(.*)\\((.)\\)")))
+    (lambda (s)
+      (cond
+       ((regexp-exec entry-regexp s)
+	=> (lambda (match)
+	     (values (match:substring match 1)
+		     (match:substring match 2))))
+       (else (values s #f))))))
+
+(define (man section key man-path)
+  (cond
+   ((procedure? man-path) (man-path))
+   ((find-man-file key section "cat" man-path) => cat-n-decode)
+   ((find-man-file key section "man" man-path) => nroff-n-decode)
+   (else
+    (if (not (zero?
+	      (with-env (("MANPATH" . ,(string-join man-path ":")))
+	        (run (,@rman/man ,@(if section `(,section) '()) ,key)
+		     stdports))))
+	(http-error http-status/not-found #f "man page not found")))))
+
+(define man-default-sections
+  '("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p"))
+
+(define (find-man-file name section cat-man man-path . maybe-sections)
+
+  (define (section-dir section)
+    (lambda (dir)
+      (file-name-as-directory
+       (string-append (file-name-as-directory dir)
+		      cat-man
+		      section))))
+
+  (let* ((prefix (if section
+		     (string-append name "." section)
+		     (string-append name ".")))
+	 (pattern (string-append (glob-quote prefix) "*"))
+	 (sections (:optional maybe-sections man-default-sections))
+	 (path (if section
+		   (map (section-dir section) man-path)
+		   (apply append
+			  (map (lambda (dir)
+				 (map (lambda (section)
+					((section-dir section) dir))
+				      sections))
+			       man-path)))))
+
+    (let loop ((path path))
+      (and (not (null? path))
+	   (let ((matches (glob (string-append (car path) pattern))))
+	     (if (not (null? matches))
+		 (car matches)
+		 (loop (cdr path))))))))
+
+(define (file->man-directory file)
+  (path-list->file-name
+   (reverse
+    (cdr
+     (reverse
+      (split-file-name
+       (file-name-directory file)))))))
+
+(define (cat-n-decode file)
+  (let ((ext (file-name-extension file)))
+    (cond
+     ((string=? ".gz" ext) (run (,@rman/gzcat ,file) stdports))
+     ((string=? ".Z" ext) (run (,@rman/zcat ,file) stdports))
+     (else (call-with-input-file
+	       file
+	     (lambda (port)
+	       (copy-inport->outport port (current-output-port))))))))
+
+(define (nroff-n-decode file)
+  (if (not (zero? (run (| (begin (cat-n-decode file))
+			  (begin
+			    (with-cwd (file->man-directory file)
+				      (exec-epf (,@rman/nroff)))))
+		       stdports)))
+      (http-error http-status/not-found #f "man page not found")))

scheme/httpd/server.scm

@@ -1,5 +1,6 @@
-#!/usr/local/bin/scsh \
--lm modules.scm -lm toothless.scm -dm -o http-top -e top -s
+#!/bin/sh
+IFS=" "
+exec scsh -lm ../packages.scm -dm -o http-top -e top -s "$0" "$@"
 !#
 
 ;;; Scheme Underground Web Server -*- Scheme -*-
@@ -12,9 +13,10 @@
 
 (define-structure http-top (export top)
   (open httpd-core
-	cgi-server-package
+	httpd-make-options
+	cgi-server
 	httpd-basic-handlers
-	seval-handler-package
+	seval-handler
 	scsh
 	scheme)
   (begin
@@ -38,7 +40,12 @@
     (define (top args)
       (display "We be jammin, now.\n") (force-output)
       (cond ((zero? (user-uid))
-	     (set-gid -2)  ; Should be (set-uid (->uid "nobody")) 
-	     (set-uid -2)))	; but NeXTSTEP loses. 
-      (initialise-request-invariant-cgi-env)
-      (httpd ph 8001 "/zu/shivers"))))
+	     (set-gid (->gid "nobody"))
+	     (set-uid (->uid "nobody"))))
+;; invariant environment is know initilialized by cgi-handler itself
+;;      (initialise-request-invariant-cgi-env)
+      (httpd (with-path-handler 
+	      ph
+	      (with-port
+	       8001 
+	       (with-root-directory "/usr/local/etc/httpd")))))))

scheme/httpd/seval.scm

@@ -0,0 +1,112 @@
+;;; Path handler for uploading Scheme code to the SU web server -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; This is really just an handler example demonstrating how to upload code 
+;;; into the server.
+
+;;; HTML forms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This path handler is suitable for receiving code entered into an
+;;; HTML text form. The Scheme code being uploaded is being POST'd to us
+;;; (from a form). See http-forms.scm for info on the format of this kind
+;;; of request. After parsing the request into the submitted string, we
+;;; parse *that* into a Scheme sexp with READ, and eval it.
+
+;;; (do/timeout secs thunk)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds.
+;;; Returns nothing useful, and THUNK gets executed in a subprocess,
+;;; so its side-effects are invisible, as well. This is a clever kludge --
+;;; it uses three subprocesses -- but I don't have interrupts, so I'm hosed.
+
+(define (do/timeout* secs thunk)
+  (run (begin (let ((timer  (fork (lambda () (sleep secs))))
+		    (worker (fork thunk)))
+		(receive (process status) (wait-any)
+		  (ignore-errors
+		   (lambda ()
+		     (signal-process (proc:pid (if (eq? worker process)
+						   timer
+						   worker))
+				     signal/kill))))))))
+(define-syntax do/timeout
+  (syntax-rules ()
+    ((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))
+
+;;; The path handler for seval ops.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (seval-handler path req)
+  (let ((request-method (request:method req)))
+    (cond 
+     ((string=? request-method "POST")	; Could do others also.
+      (seval path req))
+     (else
+      (make-http-error-response http-status/method-not-allowed req request-method)))))
+
+(define (seval path req)
+    (make-response
+     http-status/ok
+     (status-code->text http-status/ok)
+     (time)
+     "text/html"
+     '()
+     (make-reader-writer-body
+      (lambda (iport oport options)
+	(let ((sexp (read-request-sexp req iport)))
+	  (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
+	  (with-tag oport HEAD ()
+	    (newline oport)
+	    (emit-title oport "Scheme program output"))
+	  (newline oport)
+	  
+	  (with-tag oport BODY ()
+	    (newline oport)
+	    (do/timeout 
+	     10
+	     (receive vals
+		 ;; Do the computation.
+		 (begin (emit-header oport 2 "Output from execution")
+			(newline oport)
+			(with-tag oport PRE ()
+			  (newline oport)
+			  (force-output oport); In case we're gunned down.
+			  (eval-safely sexp)))
+	       
+	       ;; Pretty-print the returned value(s).
+	       (emit-header oport 2 "Return value(s)")
+	       (with-tag oport PRE ()
+		 (for-each (lambda (val) (p val oport))
+			   vals))))))))))
+
+
+;;; Read an HTTP request entity body from stdin. The Content-length:
+;;; element of request REQ's header tells how many bytes to this entity
+;;; is. The entity should be a URI-encoded form body. Pull out the
+;;;     program=<stuff>
+;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
+;;; and return it.
+
+(define (read-request-sexp req iport)
+  (cond 
+   ((get-header (request:headers req) 'content-length) =>
+    (lambda (cl-str)		 ; Take the first Content-length: header,
+      (let* ((cl-start (string-skip cl-str char-set:whitespace))	   ; skip whitespace,
+	     (cl (if cl-start			   	   ; & convert to
+		     (string->number (substring cl-str   ;     a number.
+						cl-start
+						(string-length cl-str)))
+		     0)) ; All whitespace?? -- WTF.
+	     (qs (read-string cl iport))			; Read in CL chars,
+	     (q (parse-html-form-query qs))		; and parse them up.
+	     (s (cond ((assoc "program" q) => cdr)
+		      (else (error "No program in entity body.")))))
+	(http-syslog (syslog-level debug)
+		     "Seval sexp: ~s" s)
+	(read (make-string-input-port s)))))
+   (else (error "No `Content-length:' field in POST request."))))

scheme/lib/cgi-script.scm

@@ -1,15 +1,13 @@
 ;;; NCSA's WWW Common Gateway Interface -- script-side code -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
 ;;; Copyright (c) 1995 by Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
 
-;;; Imports and non-R4RS'isms
-;;;     switch			(control structure)
-;;;     getenv read-string	(scsh)
-;;;     error
-;;; 	parse-html-form-query	(parse-html-forms package)
-
-
 ;;; This file provides routines to help you write programs in Scheme
 ;;; that can interface to HTTP servers using the CGI program interface
 ;;; to carry out HTTP transactions.
@@ -71,7 +69,7 @@
 ;;;   Otherwise, when it replies to the server, it sends back a special
 ;;;   little header that tells the server how to construct the real header
 ;;;   for the reply.
-;;; See the "spec" for further details.
+;;; See the "spec" for further details. (URL above)
 
 
 ;;; (cgi-form-query)
@@ -82,13 +80,14 @@
 ;;; This only works for GET and POST methods.
 
 (define (cgi-form-query)
-  (switch string=? (getenv "REQUEST_METHOD")
+  (let ((request-method (getenv "REQUEST_METHOD")))
+    (cond 
 
-    (("GET")
-     (parse-html-form-query (getenv "QUERY_STRING")))
+     ((string=? request-method "GET")
+      (parse-html-form-query (getenv "QUERY_STRING")))
 
-    (("POST")
-     (let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
-       (parse-html-form-query (read-string nchars))))
+     ((string=? request-method "POST")
+      (let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
+	(parse-html-form-query (read-string nchars))))
 
-    (else (error "Method not handled.")))) ; Don't be calling me.
+     (else (error "Method not handled."))))) ; Don't be calling me.

scheme/lib/crlf-io.scm

@@ -1,13 +1,10 @@
 ;;; Read cr/lf and lf terminated lines. -*- Scheme -*-
-;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
 
-;;; External dependencies and non-R4RS'isms
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; ascii->char					(To create a carriage-return)
-;;; read-line write-string force-output		(scsh I/O procs)
-;;; receive values				(MV return)
-;;; let-optionals				
-;;; "\r\n" in strings for cr/lf.		(Not R4RS)
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; (read-crlf-line [fd/port retain-crlf?]) -> string or EOF object
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -36,4 +33,18 @@
   (write-string "\r\n" port)
   (force-output port))
 
-
+(define (read-crlf-line-timeout . args)
+  (let-optionals args ((fd/port (current-input-port))
+		       (retain-crlf? #f)
+		       (timeout 8000)
+		       (max-interval 500))
+   (let loop ((waited 0) (interval 100))
+     (cond ((> waited timeout)
+	    'timeout)
+	   ((char-ready? fd/port)
+	    (read-crlf-line fd/port retain-crlf?))
+	   (else (sleep interval)
+		 (loop (+ waited interval) (min (* interval 2)
+						max-interval)))))))
+		 
+		 

scheme/lib/format-net.scm

@@ -0,0 +1,39 @@
+;; Pretty-printing of IPv4 Internet addresses
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1998 by Mike Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;; ADDRESS    address to pretty-print
+;; SEPERATOR  optional, defaults to ".", seperator between address-parts
+;; Example:
+;; (format-internet-host-address #x0a00ffff)
+;; ==> "10.0.255.255"
+;; (format-internet-host-address #x0a00ffff ":")
+;; ==> "10:0:255:255"
+
+(define (format-internet-host-address address . maybe-separator)
+
+  (let ((extract (lambda (shift)
+		   (number->string
+		    (bitwise-and (arithmetic-shift address (- shift))
+				 255)))))
+		 
+    (let-optionals maybe-separator ((separator "."))
+		   (string-append
+		    (extract 24) separator (extract 16) separator
+		    (extract 8) separator (extract 0)))))
+  
+;; does pretty-print of ports
+;; Example:
+;; (format-port #x0aff)
+;; => "10,255"
+
+(define (format-port port)
+  (string-append
+   (number->string (bitwise-and (arithmetic-shift port -8) 255))
+   ","
+   (number->string (bitwise-and port 255))))
+

scheme/lib/ftp.scm

@@ -0,0 +1,577 @@
+;;; ftp.scm -- an FTP client library for the Scheme Shell
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1998 by Eric Marsden.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+
+
+;;; Overview =========================================================
+;;
+;; This module lets you transfer files between networked machines from
+;; the Scheme Shell, using the File Transfer Protocol as described
+;; in rfc959. The protocol specifies the behaviour of a server
+;; machine, which runs an ftp daemon (not implemented by this module),
+;; and of clients (that's us) which request services from the server.
+
+
+;;; Entry points =======================================================
+;;
+;; (ftp-connect host [logfile]) -> connection
+;;     Open a command connection with the remote machine HOST.
+;;     Optionally start logging the conversation with the server to
+;;     LOGFILE, which will be appended to if it already exists, and
+;;     created otherwise. Beware, the LOGFILE contains passwords in
+;;     clear text (it is created with permissions og-rxw) !
+;;
+;; (ftp-login connection [login passwd]) -> status
+;;     Log in to the remote host. If a login and password are not
+;;     provided, they are first searched for in the user's ~/.netrc
+;;     file, or default to user "anonymous" and password "user@host"
+;;
+;; (ftp-type connection type) -> status
+;;     Change the transfer mode for future data connections. This may
+;;     be either 'ascii or 'text, respectively, for transfering text files, 
+;;     or 'binary for transfering binary files. If type is a string it
+;;     is sent verbatim to the server.
+;;
+;; (ftp-rename connection oldname newname) -> status
+;;     Change the name of oldname on the remote host to newname
+;;     (assuming sufficient permissions). oldname and newname are
+;;     strings; if prefixed with "/" they are taken relative to the
+;;     server's root, and otherwise they are relative to the current
+;;     directory. Note that in the case of anonymous ftp (user
+;;     "anonymous" or "ftp"), the server root is different from the
+;;     root of the servers's filesystem.
+;;
+;; (ftp-delete connection file) -> status
+;;     Delete file from the remote host (assuming the user has
+;;     appropriate permissions).
+;;
+;; (ftp-cd connection dir) -> status
+;;     Change the current directory on the server.
+;;
+;; (ftp-cdup connection) -> status
+;;     Move to the parent directory on the server.
+;;
+;; (ftp-pwd connection) -> string
+;;     Return the current directory on the remote host, as a string.
+;;
+;; (ftp-ls connection) -> status
+;;     Provide a listing of the current directory's contents, in short
+;;     format, ie as a list of filenames.
+;;
+;; (ftp-dir connection) -> status
+;;     Provide a listing of the current directory's contents, in long
+;;     format. Most servers (Unix, MS Windows, MacOS) use a standard
+;;     format with one file per line, with the file size and other
+;;     information, but other servers (VMS, ...) use their own format.
+;;
+;; (ftp-get connection remote-file [local-file]) -> status | string
+;;     Download remote-file from the FTP server. If local-file is a
+;;     string, save the data to local-file on the local host;
+;;     otherwise save to a local file named remote-file. remote-file
+;;     and local-file may be absolute file names (with a leading `/'),
+;;     or relative to the current directory. It local-file is #t,
+;;     output data to (current-output-file), and if it is #f return
+;;     the data as a string.
+;;
+;; (ftp-put connection local-file [remote-file]) -> status
+;;     Upload local-file to the FTP server. If remote-file is
+;;     specified, the save the data to remote-file on the remote host;
+;;     otherwise save to a remote file named local-file. local-file
+;;     and remote-file may be absolute file names (with a leading
+;;     `/'), or relative to the current directory.
+;;
+;; (ftp-rmdir connection dir) -> status
+;;     Remove the directory DIR from the remote host (assuming
+;;     sufficient permissions).
+;;
+;; (ftp-mkdir connection dir) -> status
+;;     Create a new directory named DIR on the remote host (assuming
+;;     sufficient permissions).
+;;
+;; (ftp-modification-time connection file) -> date
+;;     Request the time of the last modification of FILE on the remote
+;;     host, and on success return a Scsh date record. This command is
+;;     not part of RFC959 and is not implemented by all servers, but
+;;     is useful for mirroring.
+;;
+;; (ftp-size connection file) -> integer
+;;     Return the size of FILE in bytes.
+;;
+;; (ftp-abort connection) -> status
+;;     Abort the current data transfer. Not particularly useful with
+;;     this implementation since the data transfer commands only
+;;     return once the transfer is complete.
+;;
+;; (ftp-quit connection) -> status
+;;     Close the connection to the remote host. The connection object
+;;     is useless after a quit command.
+
+
+;;; Unimplemented =====================================================
+;;
+;; This module has no support for sites behind a firewall (because I
+;; am unable to test it). It shouldn't be very tricky; it only
+;; requires using passive mode. Might want to add something like the
+;; /usr/bin/ftp command `restrict', which implements data port range
+;; restrictions.
+;;
+;; The following rfc959 commands are not implemented:
+;;
+;; * ACCT (account; this is ignored by most servers)
+;; * SMNT (structure mount, for mounting another filesystem)
+;; * REIN (reinitialize connection)
+;; * LOGOUT (quit without interrupting ongoing transfers)
+;; * STRU (file structure)
+;; * ALLO (allocate space on server)
+
+
+;;; Portablitity =====================================================
+;;
+;; * the netrc.scm module for parsing ~/.netrc files
+;; * scsh socket code
+;; * scsh records
+;; * receive for multiple values
+;; * Scheme48 signals/handlers
+
+
+;;; Related work ======================================================
+;;
+;; * rfc959 describes the FTP protocol; see
+;;   http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
+;;
+;; * /anonymous@sunsite.unc.edu:/pub/Linux/libs/ftplib.tar.gz is a
+;;   library similar to this one, written in C, by Thomas Pfau
+;;
+;; * FTP.pm is a Perl module with similar functionality (available
+;;   from http://www.perl.com/CPAN)
+;;
+;; * Emacs gets transparent remote file access from ange-ftp.el by
+;;   Ange Norman. However, it cheats by using /usr/bin/ftp
+;;
+;; * Siod (a small-footprint Scheme implementation by George Carette)
+;;   comes with a file ftp.scm with a small subset of these functions
+;;   defined
+
+
+;;; TODO ============================================================
+;;
+;; * handle passive mode and firewalls
+;; * Unix-specific commands such as SITE UMASK, SITE CHMOD
+;; * object-based interface? (like SICP message passing)
+;; * improved error handling
+;; * a lot of the calls to format could be replaced by calls to
+;;   string-join. Maybe format is easier to read?
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Communication is initiated by the client. The server responds to
+;; each request with a three digit status code and an explanatory
+;; message, and occasionally with data (which is sent via a separate,
+;; one-off channel). The client starts by opening a command connection
+;; to a well known port on the server machine. Messages send to the
+;; server are of the form
+;;
+;;          CMD [ <space> arg ] <CR> <LF>
+;;
+;; Replies from the server are of the form
+;;
+;;          xyz <space> Informative message <CR> <LF>
+;;
+;; where xyz is a three digit code which indicates whether the
+;; operation succeeded or not, whether the server is waiting for more
+;; data, etc. The server may also send multiline messages of the form
+;;
+;;          xyz- <space> Start of multiline message <CR> <LF>
+;;          [ <space>+ More information ]* <CR> <LF>
+;;          xyz <space> End of multiline message <CR> <LF>
+;;
+;; Some of the procedures in this module extract useful information
+;; from the server's reply, such as the size of a file, or the name of
+;; the directory we have moved to. These procedures return either the
+;; extracted information, or #f to indicate failure. Other procedures
+;; return a "status", which is either the server's reply as a string,
+;; or #f to signify failure.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; beware, the log file contains password information!
+;;: string [ x string x port] -> connection
+(define (ftp-connect host . args)
+  (let-optionals* args ((logfile #f))
+    (let* ((LOG (and logfile
+		     (open-output-file logfile
+				       (if (file-exists? logfile)
+					   (bitwise-ior open/write open/append)
+					   (bitwise-ior open/write open/create))
+				       #o600)))
+	   (hst-info (host-info host))
+	   (hostname (host-info:name hst-info))
+	   (srvc-info (service-info "ftp" "tcp"))
+	   (sock (socket-connect protocol-family/internet
+				 socket-type/stream
+				 hostname
+				 (service-info:port srvc-info)))
+	   (connection (make-ftp-connection hostname
+					    sock
+					    LOG "" "")))
+      (ftp-log connection
+	       (format #f "~%-- ~a: opened ftp connection to ~a"
+		       (date->string (date)) ; doesn't seem to be buggy in v0.6
+		       ;"Dummy date"       ; (format-time-zone) is buggy in v0.5.1
+		       hostname))
+      (ftp-read-response connection "220") ; the initial welcome banner
+      connection)))
+
+;; Send user information to the remote host. Args are optional login
+;; and password. If they are not provided, the Netrc module is used to
+;; try to determine a login and password for the server. If not found we
+;; default to login "anonymous" with password user@host.
+;;: connection [ x string x password ] -> status
+(define (ftp-login connection . args)
+  (let ((netrc-record (netrc:parse)))
+    (let-optionals* args  
+		    ((login 
+		      (netrc:lookup-login netrc-record 
+					  (ftp-connection:host-name connection)))
+		     (password 
+		      (netrc:lookup-password netrc-record 
+					     (ftp-connection:host-name connection))))
+    (set-ftp-connection:login connection login)
+    (set-ftp-connection:password connection password)
+    (ftp-send-command connection (format #f "USER ~a" login) "...")  ; "331"
+    (ftp-send-command connection (format #f "PASS ~a" password) "2..")))) ; "230"
+
+;; Type must be one of 'binary or 'text or 'ascii, or a string which will be
+;; sent verbatim
+;;: connection x symbol|string -> status
+(define (ftp-type connection type)
+  (let ((ttype (cond
+          ((string? type) type)
+          ((eq? type 'binary) "I")
+          ((or (eq? type 'ascii)
+	       (eq? type 'text)) "A")
+          (else
+           (call-error "type must be one of 'binary or 'text or 'ascii" ftp-type type)))))
+    (ftp-send-command connection (format #f "TYPE ~a" ttype))))
+
+;;: connection x string x string -> status
+(define (ftp-rename connection oldname newname)
+  (ftp-send-command connection (format #f "RNFR ~a" oldname) "35.")
+  (ftp-send-command connection (format #f "RNTO ~a" newname) "25."))
+
+;;: connection x string -> status
+(define (ftp-delete connection file)
+  (ftp-send-command connection (format #f "DELE ~a" file) "25."))
+
+;;: connection x string -> status
+(define (ftp-cd connection dir)
+  (ftp-send-command connection (format #f "CWD ~a" dir)))
+
+;;: connection -> status
+(define (ftp-cdup connection)
+  (ftp-send-command connection "CDUP" "250"))
+
+
+;;: on success return the new directory as a string
+(define (ftp-pwd connection)
+  (let* ((response (ftp-send-command connection "PWD" "2..")) ;; 257
+         (match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or response ""))))
+    (match:substring match 1)))
+
+;;: connection x string -> status
+(define (ftp-rmdir connection dir)
+  (ftp-send-command connection (format #f "RMD ~a" dir)))
+
+;;: connection x string -> status
+(define (ftp-mkdir connection dir)
+  (ftp-send-command connection (format #f "MKD ~a" dir)))
+
+;; On success return a Scsh date record. This message is not part of
+;; rfc959 but seems to be supported by many ftp servers (it's useful
+;; for mirroring)
+;;: connection x string -> date
+(define (ftp-modification-time connection file)
+  (let* ((response (ftp-send-command connection
+                                     (format #f "MDTM ~a" file)))
+         (match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or response "")))
+         (timestr (and match (match:substring match 1))))
+    (and timestr
+         (let ((year  (substring timestr 0 4))
+               (month (substring timestr 4 6))
+               (mday  (substring timestr 6 8))
+               (hour  (substring timestr 8 10))
+               (min   (substring timestr 10 12))
+               (sec   (substring timestr 12 14)))
+           (make-date (string->number sec)
+                      (string->number min)
+                      (string->number hour)
+                      (string->number mday)
+                      (string->number month)
+                      (- (string->number year) 1900))))))
+
+;; On success return the size of the file in bytes.
+;;: connection x string -> integer
+(define (ftp-size connection file)
+  (let* ((response (ftp-send-command connection
+                                     (format #f "SIZE ~a" file)
+                                     "2..")))
+    (and (string? response)
+         (string->number (substring response
+                                    4 (- (string-length response) 1))))))
+
+;; Abort the current data transfer. Maybe we should close the data
+;; socket?
+;;: connection -> status
+(define (ftp-abort connection)
+  (ftp-send-command connection "ABOR"))
+
+;;: connection -> status
+(define (ftp-quit connection)
+  (ftp-send-command connection "QUIT" "221")
+  (close-socket (ftp-connection:command-socket connection)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following commands require the use of a data connection as well
+;; as the command connection. The command and the server's reply are
+;; transmitted via the command connection, while the data is
+;; transmitted via the data connection (you could have guessed that,
+;; right?).
+;;
+;; The data socket is created by the client, who sends a PORT command
+;; to the server to indicate on which port it is ready to accept a
+;; connection. The port command specifies an IP number and a port
+;; number, in the form of 4+2 comma-separated bytes. The server then
+;; initiates the data transfer. A fresh data connection is created for
+;; each data transfer (unlike the command connection which stays open
+;; during the entire conversation with the server).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;: connection [ x string ] -> status
+(define (ftp-ls connection . maybe-dir)
+  (let* ((sock (ftp-open-data-connection connection)))
+    (ftp-send-command connection
+                      (ftp-build-command-string "NLST" maybe-dir)
+                      "1..")
+    (receive (newsock newsockaddr)
+             (accept-connection sock)
+             (dump (socket:inport newsock))
+             (close-socket newsock)
+             (close-socket sock)
+             (ftp-read-response connection "2.."))))
+
+;;: connection [ x string ] -> status
+(define (ftp-dir connection . maybe-dir)
+  (let* ((sock (ftp-open-data-connection connection)))
+    (ftp-send-command connection
+                      (ftp-build-command-string "LIST" maybe-dir)
+                      "1..")
+    (receive (newsock newsockaddr)
+             (accept-connection sock)
+             (dump (socket:inport newsock))
+             (close-socket newsock)
+             (close-socket sock)
+             (ftp-read-response connection "2.."))))
+
+
+;; maybe-local may be a filename to which the data should be written,
+;; or #t to write data to stdout (to current-output-port to be more
+;; precise), or #f to stuff the data in a string (which is returned),
+;; or nothing to output to a local file with the same name as the
+;; remote file.
+;;: connection x string [x string | #t | #f] -> status | string
+(define (ftp-get connection remote-file . maybe-local)
+  (let* ((sock (ftp-open-data-connection connection))
+         (local (if (pair? maybe-local)
+                    (car maybe-local)
+                    'empty))
+         (OUT (cond ((string? local) (open-output-file local))
+                    ((eq? local #t) (current-output-port))
+                    ((eq? local #f) (make-string-output-port))
+                    (else
+                     (open-output-file remote-file)))))
+    (ftp-send-command connection
+                      (format #f "RETR ~a" remote-file)
+                      "150")
+    (receive (newsock newsockaddr)
+             (accept-connection sock)
+             (with-current-output-port OUT
+                (dump (socket:inport newsock)))
+             (close-socket newsock)
+             (close-socket sock)
+             (let ((status (ftp-read-response connection "2..")))
+               (if (string? local) (close OUT))
+               (if (eq? local #f)
+                   (string-output-port-output OUT)
+                   status)))))
+
+
+;; FIXME: should have an optional argument :rename which defaults to
+;; false, which would make us upload to a temporary name and rename at
+;; the end of the upload. This atomicity is important for ftp or http
+;; servers which are serving a load, and to avoid problems with "no
+;; space on device".
+
+;; optional argument maybe-remote-file is the name under which we wish
+;; the file to appear on the remote machine. If omitted the file takes
+;; the same name on the FTP server as on the local host.
+;;: connection x string [ x string ] -> status
+(define (ftp-put connection local-file . maybe-remote-file)
+  (let-optionals* maybe-remote-file ((remote-file #f))
+    (let* ((sock (ftp-open-data-connection connection))
+           (IN (open-input-file local-file))
+	   (cmd (format #f "STOR ~a" (or remote-file local-file))))
+      (ftp-send-command connection cmd "150")
+      (receive (newsock newsockaddr)
+	       (accept-connection sock)
+	       (with-current-output-port (socket:outport newsock) (dump IN))
+	       (close (socket:outport newsock)) ; send the server EOF
+	       (close-socket newsock)
+	       (let ((status (ftp-read-response connection "2..")))
+		 (close IN)
+		 (close-socket sock)
+		 status)))))
+
+;;: connection x string [x string] -> status
+(define (ftp-append connection local-file . maybe-remote-file)
+  (let-optionals* maybe-remote-file ((remote-file #f))
+    (let* ((sock (ftp-open-data-connection connection))
+	   (IN (open-input-file local-file))
+	   (cmd (format #f "APPE ~a" (or remote-file local-file))))
+      (ftp-send-command connection cmd "150")
+      (receive (newsock newsockaddr)
+	       (accept-connection sock)
+	       (with-current-output-port (socket:outport newsock)
+					 (dump IN))
+	       (close (socket:outport newsock)) ; send the server EOF
+	       (close-socket newsock)
+	       (let ((status (ftp-read-response connection "2..")))
+		 (close IN)
+		 (close-socket sock)
+		 status)))))
+
+;; send a command verbatim to the remote server and wait for a
+;; response.
+;;: connection x string -> status
+(define (ftp-quot connection cmd)
+  (ftp-send-command connection cmd))
+
+
+;; ------------------------------------------------------------------------
+;; no exported procedures below
+
+(define (ftp-open-data-connection connection)
+  (let* ((sock (create-socket protocol-family/internet
+                              socket-type/stream))
+         (sockaddr (internet-address->socket-address
+                    internet-address/any
+                    0)))                ; 0 to accept any port
+    (set-socket-option sock level/socket socket/reuse-address #t)
+    (set-socket-option sock level/socket socket/linger 120)
+    (bind-socket sock sockaddr)
+    (listen-socket sock 0)
+    (ftp-send-command connection        ; send PORT command
+                      (ftp-build-PORT-string (socket-local-address sock)))
+    sock))
+
+
+
+;; TODO: Unix-specific commands
+;; SITE UMASK 002
+;; SITE IDLE 60
+;; SITE CHMOD 755 filename
+;; SITE HELP
+
+
+
+;; We cache the login and password to be able to relogin automatically
+;; if we lose the connection (a la ange-ftp). Not implemented.
+(define-record ftp-connection
+  host-name
+  command-socket
+  logfd
+  login
+  password)
+
+(define-condition-type 'ftp-error '(error))
+(define ftp-error? (condition-predicate 'ftp-error))
+
+
+(define (ftp-build-PORT-string sockaddr)
+  (let* ((hst-info (host-info (system-name)))
+         (ip-address (car (host-info:addresses hst-info))))
+  (receive (hst-address srvc-port)
+           (socket-address->internet-address sockaddr)
+           (let* ((num32 ip-address)
+                  (num24 (arithmetic-shift num32 -8))
+                  (num16 (arithmetic-shift num24 -8))
+                  (num08 (arithmetic-shift num16 -8))
+                  (byte0 (bitwise-and #b11111111 num08))
+                  (byte1 (bitwise-and #b11111111 num16))
+                  (byte2 (bitwise-and #b11111111 num24))
+                  (byte3 (bitwise-and #b11111111 num32)))
+             (format #f "PORT ~a,~a,~a,~a,~a,~a"
+                     byte0 byte1 byte2 byte3
+                     (arithmetic-shift srvc-port -8) ; high order byte
+                     (bitwise-and #b11111111 srvc-port) ; lower order byte
+                     )))))
+  
+
+(define (ftp-send-command connection command . maybe-expected)
+  (let-optionals* maybe-expected ((expected "2.."))
+    (let* ((sock (ftp-connection:command-socket connection))
+	   (OUT (socket:outport sock)))
+      (write-string command OUT)
+      (write-crlf OUT)
+      (ftp-log connection (format #f "<- ~a" command))
+      (ftp-read-response connection expected))))
+
+
+;; This is where we check that the server's 3 digit status code
+;; corresponds to what we expected. EXPECTED is a string of the form
+;; "250", which indicates we are expecting a 250 code from the server,
+;; or "2.." which means that we only require the first digit to be 2
+;; and don't care about the rest. If the server's response doesn't
+;; match EXPECTED, we raise an ftp-error (which is catchable; look at
+;; pop3.scm to see how). Since this is implemented as a regexp, you
+;; can also specify more complicated acceptable responses of the form
+;; "2[4-6][0-9]". The code permits you to match the server's verbose
+;; message too, but beware that the messages change from server to
+;; server.
+(define (ftp-read-response connection . maybe-expected)
+  (let-optionals* maybe-expected ((expected "2.."))
+    (let* ((sock (ftp-connection:command-socket connection))
+	   (IN (socket:inport sock))
+	   (response (read-line IN)))
+      (ftp-log connection (format #f "-> ~a" response))
+      (or (string-match expected response)
+	  (signal 'ftp-error response))
+      ;; handle multi-line responses
+      (if (equal? (string-ref response 3) #\-)
+	  (let loop ((code (string-append (substring response 0 3) " "))
+		     (line (read-line IN)))
+	    (ftp-log connection (format #f "-> ~a" line))
+	    (set! response (string-join (list response line "\n")))
+	    (or (string-match code line)
+		(loop code (read-line IN)))))
+      response)))
+
+
+(define (ftp-build-command-string str . opt-args)
+  (if (string? opt-args)
+      (string-join (list str arg))
+      str))
+
+(define (ftp-log connection line)
+  (let ((LOG (ftp-connection:logfd connection)))
+    (and LOG
+         (write-string line LOG)
+         (write-string "\n" LOG)
+         (force-output LOG))))
+
+;; EOF

scheme/lib/htmlout.scm

@@ -1,10 +1,11 @@
 ;;; Simple code for doing structured html output. -*- Scheme -*-
-;;; Copyright (c) 1995 by Olin Shivers.
 
-;;; External dependencies
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; format			; Output
-;;; receive values		; Multiple-value return
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers.
+;;; Copyright (c) 1996 by Mike Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; - An attribute-quoter, that will map an attribute value to its
 ;;;   HTML text representation -- surrounding it with single or double quotes,
@@ -26,7 +27,7 @@
 ;;;     <tag name1="val1" name2="val2" ...>
 
 (define (emit-tag out tag . attrs)
-  (let ((out (if (eq? out #t) (current-output-port) out)))
+  (let ((out (fmt->port out)))
     (display "<" out)
     (display tag out)
     (for-each (lambda (attr)
@@ -57,9 +58,7 @@
 				     (cdr args)))
 			   (values (current-output-port) args))
 
-    (apply emit-tag out 'p attrs)
-    (newline out)
-    (newline out)))
+    (apply emit-tag out 'p attrs)))
 
 
 ;;; <TITLE> Make Money Fast!!! </TITLE>
@@ -118,10 +117,11 @@
 
 (define (with-tag* out tag thunk . attrs)
   (apply emit-tag out tag attrs)
-  (call-with-values thunk
-    (lambda results
-      (emit-close-tag out tag)
-      (apply values results))))
+  (let ((out (fmt->port out)))
+    (call-with-values thunk
+		      (lambda results
+			(emit-close-tag out tag)
+			(apply values results)))))
 
 
 (define (fmt->port x)
@@ -131,9 +131,6 @@
 ;;; double-quote to their HTML escape sequences.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;; Mike Sperber <sperber@informatik.uni-tuebingen.de>
-;; This is fairly simple-minded
-
 ;; Note iso8859-1 above 127 is perfectly OK
 
 (define *html-entity-alist*
@@ -144,7 +141,7 @@
    (cons (ascii->char 34) "&quot;")))
 
 (define *html-entities*
-  (chars->char-set (map car *html-entity-alist*)))
+  (list->char-set (map car *html-entity-alist*)))
 
 (define *html-entity-table*
   (let ((v (make-vector 256 #f)))
@@ -164,33 +161,33 @@
 
 (define (escape-html s)
   (let ((target-length
-	 (string-reduce 0
-			(lambda (c i)
-			  (+ i
-			     (if (char-set-contains? *html-entities* c)
-				 (string-length 
-				  (vector-ref *html-entity-table*
-					      (char->ascii c)))
-				 1)))
-			s)))
+	 (string-fold (lambda (c i)
+			(+ i
+			   (if (char-set-contains? *html-entities* c)
+			       (string-length 
+				(vector-ref *html-entity-table*
+					    (char->ascii c)))
+			       1)))
+		      0
+		      s)))
     (if (= target-length (string-length s))
 	s
 	(let ((target (make-string target-length)))
-	  (string-reduce
-	    0
-	    (lambda (c i)
-	      (+ i
-		 (if (char-set-contains? *html-entities* c)
-		     (let ((entity (vector-ref *html-entity-table* (char->ascii c))))
-		       (string-set-substring! target i entity)
-		       (string-length entity))
-		      (begin 
-			(string-set! target i c)
-			1))))
-	    s)
+	  (string-fold
+	   (lambda (c i)
+	     (+ i
+		(if (char-set-contains? *html-entities* c)
+		    (let ((entity (vector-ref *html-entity-table* (char->ascii c))))
+		      (string-set-substring! target i entity)
+		      (string-length entity))
+		    (begin 
+		      (string-set! target i c)
+		      1))))
+	   0
+	   s)
 	  target))))
 
 (define (emit-text s . maybe-port)
   (if (null? maybe-port)
       (write-string (escape-html s))
-      (write-string (escape-html s) (car maybe-port))))
+      (write-string (escape-html s) (fmt->port (car maybe-port)))))

scheme/lib/ls.scm

@@ -0,0 +1,335 @@
+; ls clone in scsh
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1998 Michael Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+; This currently does a whole bunch of stats on every file in some
+; cases.  In a decent OS implementation, this stuff is cached, so
+; there isn't any problem, at least not in theory :-)
+
+; FLAGS is a list of symbols from:
+;
+; all        - include stuff starting with "."
+; recursive  - guess what
+; long       - output interesting information per file
+; directory  - display only the information for the directory named
+; flag       - flag files as per their types
+; columns    - sorts output vertically in a multicolumn format
+
+(define ls-crlf? (make-fluid #f))
+
+(define (ls flags paths . maybe-port)
+  (let* ((port (optional maybe-port (current-output-port)))
+	 (paths (if (null? paths)
+		    (list (cwd))
+		    paths))
+	 (only-one? (null? (cdr paths))))
+    (call-with-values
+     (lambda () (parse-flags flags))
+     (lambda (all? recursive? long? directory? flag? columns?)
+       (real-ls paths
+		(if only-one? #f "")
+		all? recursive? long? directory? flag? columns?
+		port)))))
+
+(define (parse-flags flags)
+  (let ((all? (memq 'all flags))
+	(recursive? (memq 'recursive flags))
+	(long? (memq 'long flags))
+	(directory? (memq 'directory flags))
+	(flag? (memq 'flag flags))
+	(columns? (memq 'columns flags)))
+    (values all? recursive? long? directory? flag? columns?)))
+
+(define (real-ls paths prefix
+		 all? recursive? long? directory? flag? columns?
+		 port)
+  (let ((first #t))
+    (for-each
+     (lambda (path)
+       (if first
+	   (set! first #f)
+	   (ls-newline port))
+       (if prefix
+	   (format port "~A~A:~%" prefix path))
+       (ls-path path all? recursive? long? directory? flag? columns? port))
+     paths)))
+
+(define (ls-path path all? recursive? long? directory? flag? columns? port)
+  (cond
+   ((and (not directory?)                          ;; go into directories
+	 (or (and (file-name-directory? path)      ;; path specifies directory
+		  (file-directory? path #t))       ;; either as a symlink (if the names end with a slash)
+	     (file-directory? path #f)))           ;; or not
+    (ls-directory path all? recursive? long? directory? flag? columns? port))
+   (else
+    (if (or long? flag?)                           ;; see LS-DIRECTORY for details
+	(ls-file (cons path (file-info path #f)) long? flag? port)
+	(ls-file (cons path #f) long? flag? port)))))
+
+(define (ls-directory directory all? recursive? long? directory? flag? columns? port)
+; terminology: a FILE-NAME is the name of a file
+;              a FILE is a pair whose car is a file-name and whose cdr is 
+;                either its file-info-object or #f (if not needed)
+;              a INFO is a file-info-object
+  (let* ((directory (file-name-as-directory directory))
+	 (substantial-directory (string-append directory "."))
+	 (file-names (directory-files substantial-directory all?)))
+    (with-cwd*
+     substantial-directory
+     (lambda ()
+       (let ((files (if (or recursive? long? flag?)    ; these are the flags for which we need the file-info
+			(map (lambda (file-name)
+			       (cons file-name (file-info file-name #f)))
+			     file-names)
+			(map (lambda (file-name) (cons file-name #f))
+			     file-names))))
+
+	 (if (and (not long?)
+		  columns?)
+	     (ls-files-columns files flag? port)
+	     (ls-files-column files long? flag? port))
+       
+	 (if recursive?
+	     (let ((directories
+		    (map (lambda (file) (car file))
+			 (filter (lambda (file) 
+				   (eq? (file-info:type (cdr file)) 'directory))
+				 files))))
+	       (if (not (null? directories))
+		   (begin
+		     (ls-newline port)
+		     (real-ls directories directory
+			      all? recursive? long? directory? flag? columns?
+			      port))))))))))
+
+(define *width* 79)
+
+(define (ls-files-columns files flag? port)
+  (let* ((max-file-name-width
+	  (if (null? files)
+	      0
+	      (apply max (map (lambda (file) (string-length (car file))) files))))
+	 (max-file-name-width
+	  (if flag?
+	      (+ 1 max-file-name-width)
+	      max-file-name-width))
+
+	 (column-width (+ 2 max-file-name-width))
+
+	 (columns (quotient *width*
+			    column-width))
+	 (columns (if (zero? columns)
+		      1
+		      columns))
+
+	 (number-of-files (length files))
+	 (rows (quotient (+ number-of-files (- columns 1))
+			 columns))
+
+	 (tails
+	  (do ((column 0 (+ 1 column))
+	       (tails (make-vector columns)))
+	      ((= column columns)
+	       tails)
+	    (vector-set! tails column
+			 (list-tail-or-null files (* rows column))))))
+
+    (do ((row 0 (+ 1 row)))
+	((= row rows))
+      (do ((column 0 (+ 1 column)))
+	  ((= column columns))
+	(let ((tail (vector-ref tails column)))
+	  (if (not (null? tail))
+	      (let* ((file (car tail))
+		     (width (display-file file flag? port)))
+		(display-spaces (- column-width width) port)
+		(vector-set! tails column (cdr tail))))))
+      (ls-newline port))))
+
+(define (list-tail-or-null list index)
+  (let loop ((list list) (index index))
+    (cond
+     ((null? list) list)
+     ((zero? index) list)
+     (else (loop (cdr list) (- index 1))))))
+
+(define (ls-files-column files long? flag? port)
+  (for-each
+   (lambda (file)
+     (ls-file file long? flag? port))
+   files))
+
+(define (ls-file file long? flag? port)
+  (if long?
+      (ls-file-long file flag? port)
+      (ls-file-short file flag? port)))
+
+(define (ls-file-short file flag? port)
+  (display-file file flag? port)
+  (ls-newline port))
+
+(define (ls-file-long file flag? port)
+  (let ((info (cdr file)))
+    (display-permissions info port)
+    (display-decimal-justified (file-info:nlinks info) 4 port)
+    (write-char #\space port)
+    (let* ((uid (file-info:uid info))
+	   (user-name
+	    (call-with-current-continuation
+	     (lambda (escape)
+	       (with-handler
+		(lambda (condition more)
+		  (escape (number->string uid)))
+		(lambda ()
+		  (user-info:name (user-info uid))))))))
+      (display-padded user-name 9 port))
+    (let* ((gid (file-info:gid info))
+	   (group-name
+	    (call-with-current-continuation
+	     (lambda (escape)
+	       (with-handler
+		(lambda (condition more)
+		  (escape (number->string gid)))
+		(lambda ()
+		  (group-info:name (group-info gid))))))))
+      (display-padded group-name 9 port))
+    (display-decimal-justified (file-info:size info) 7 port)
+    (write-char #\space port)
+    (display-time  (file-info:mtime info) port)
+    (write-char #\space port)
+    (display-file file flag? port)
+    (if (eq? (file-info:type info) 'symlink)
+	(begin
+	  (display " -> " port)
+	  (display (read-symlink (car file)) port)))
+    (ls-newline port)))
+
+(define *year-seconds* (* 365 24 60 60))
+
+(define (display-time the-time port)
+  (let ((time-difference (abs (- (time) the-time)))
+	(date (date the-time 0)))
+    (if (< time-difference *year-seconds*)
+	(display (format-date "~b ~d ~H:~M" date) port)
+	(display (format-date "~b ~d ~Y " date) port))))
+
+(define (display-file file flag? port)
+  (let ((file-name (car file)))
+    (display file-name port)
+    (if (maybe-display-flag (cdr file) flag? port)
+	(+ 1 (string-length file-name))
+	(string-length file-name))))
+
+(define (maybe-display-flag info flag? port)
+  (and flag?
+      (begin
+	(cond
+	 ((eq? (file-info:type info) 'directory)
+	  (write-char #\/ port))
+	 ((eq? (file-info:type info) 'symlink)	
+	  (write-char #\@ port))
+	 ; 'executable: bits 0, 3 or 6 are set:
+	 ; that means, 'AND' with 1+8+64=73 results in a nonzero-value
+	 ; note: there is no distinction between user's, group's and other's permissions
+	 ; (as the real GNU-ls does not)
+	 ((not (zero? (bitwise-and (file-info:mode info) 73)))
+	  (write-char #\* port))
+	 ((eq? (file-info:type info) 'socket)	
+	  (write-char #\= port))
+	 ((eq? (file-info:type info) 'fifo)	
+	  (write-char #\| port)))
+	#t)))
+
+(define (display-permissions info port)
+  (case (file-info:type info)
+    ((directory)
+     (write-char #\d port))
+    ((symlink)
+     (write-char #\l port))
+    ((fifo)
+     (write-char #\p port))
+    (else
+     (write-char #\- port)))
+  (let ((mode (file-info:mode info))
+	(bit 8))
+    (for-each
+     (lambda (id)
+       (if (not (zero? (bitwise-and (arithmetic-shift 1 bit)
+				    mode)))
+	   (write-char id port)
+	   (write-char #\- port))
+       (set! bit (- bit 1)))
+     '(#\r #\w #\x #\r #\w #\x #\r #\w #\x))))
+
+(define (display-decimal-justified number width port)
+  (display-justified (number->string number) width port))
+
+(define (display-justified string width port)
+  (let ((length (string-length string)))
+    (if (< length width)
+	(display-spaces (- width length) port))
+    (display string port)))
+
+(define (display-padded string width port)
+  (let ((length (string-length string)))
+    (display string port)
+    (if (< length width)
+	(display-spaces (- width length) port))))
+
+(define (display-spaces number port)
+  (do ((i 0 (+ 1 i)))
+      ((= i number))
+    (write-char #\space port)))
+
+;; Convert Unix-style arguments to flags suitable for LS.
+
+(define (arguments->ls-flags args)
+  (let loop ((args args) (flags '()))
+    (if (null? args)
+	flags
+	(cond
+	 ((argument->ls-flags (car args))
+	  => (lambda (new-flags)
+	       (loop (cdr args) (append new-flags flags))))
+	 (else #f)))))
+
+(define (argument->ls-flags arg)
+  (let ((arg (if (symbol? arg)
+		 (symbol->string arg)
+		 arg)))
+    (if (or (string=? "" arg)
+	    (not (char=? #\- (string-ref arg 0))))
+	#f
+	(let loop ((chars (cdr (string->list arg))) (flags '()))
+	  (cond
+	   ((null? chars)
+	    flags)
+	   ((char->flag (car chars))
+	    => (lambda (flag)
+		 (loop (cdr chars) (cons flag flags))))
+	   (else #f))))))
+
+(define (char->flag char)
+  (case char
+    ((#\a) 'all)
+    ((#\R) 'recursive)
+    ((#\l) 'long)
+    ((#\d) 'directory)
+    ((#\F) 'flag)
+    ((#\C) 'columns)
+    (else #f)))
+
+(define (optional maybe-arg default-exp)
+  (cond
+   ((null? maybe-arg) default-exp)
+   ((null? (cdr maybe-arg)) (car maybe-arg))
+   (else (error "too many optional arguments" maybe-arg))))
+
+(define (ls-newline port)
+  (if (fluid ls-crlf?)
+      (write-crlf port)
+      (newline port)))

scheme/lib/netrc.scm

@@ -0,0 +1,388 @@
+;;; netrc.scm -- parse authentication information contained in ~/.netrc
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1998 by Eric Marsden
+;;; Copyright (c) 2002 by Andreas Bernauer.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; Overview =====================================================
+;;
+;; On Unix systems the ~/.netrc file (in the user's home directory)
+;; may contain information allowing automatic login to remote hosts.
+;; The format of the file is defined in the ftp(1) manual page.
+;; Example lines are
+;; 
+;;    machine ondine.cict.fr login marsden password secret
+;;    default login anonymous password user@site
+;;
+;; The ~/.netrc file should be protected by appropriate permissions,
+;; and (like /usr/bin/ftp) this library will refuse to read the file if
+;; it is badly protected. (unlike /usr/bin/ftp this library will always 
+;; refuse to read the file -- /usr/bin/ftp refuses it only if the password
+;; is given for a non-default account). Appropriate permissions are set
+;; if only the user has permissions on the file.
+;;
+;; Note following restrictions / differences:
+;; * The macdef statement (defining macros) is not supported.
+;; * The settings for one machine must be on a single line.
+;; * The is no error proof while reading the file.
+;; * default need not be the last line of the netrc-file
+
+
+
+;;; Entry points =======================================================
+;;
+;; What you probably want, is to read out the default netrc-file. Do the
+;; following:
+;;
+;; (let ((netrc-record (netrc:parse)))
+;;    (netrc:lookup netrc-record "name of the machine")) 
+;; 
+;; and you will receive three values: login-name, password and account-name.
+;; If you only want the login-name or the password, use netrc:lookup-login
+;; or netrc:lookup-password resp.
+;;
+;; You will get either the login / password for the specified machine, 
+;; or a default login / password if the machine is unknown.
+;; 
+;;
+;; (user-mail-address) -> string
+;;    Calculate the user's email address, as per the Emacs function of
+;;    the same name. Will take into account the environment variable
+;;    REPLYTO, if set. Otherwise the mail-address will look like
+;;    user@hostname.
+;;
+;; (netrc:parse [filename [fallback-password [fallback-login]]]) 
+;;  -> netrc-record
+;;    * parses the netrc file and returns a netrc-record, containing all
+;;      necessary information for the following procedures.
+;;    * FILENAME defaults to "~/.netrc"
+;;      FALLBACK-PASSWORD defaults to the result of (user-mail-address)
+;;      FALLBACK-LOGIN defaults to "anonymous"
+;;    * if the netrc file does not provide a default password or a default 
+;;      login (stated by the "default" statement), FALLBACK-PASSWORD and 
+;;      FALLBACK-LOGIN will be used as default password or login, respectively.
+;;      (thus, user-mail-address is only called if the netrc file does not 
+;;      contain a default specification)
+;;    * if the netrc file does not exist, a netrc-record filled with
+;;      default values is returned.
+;;    * if the netrc file does not have the correct permissions, a message is
+;;      printed to current error port and a netrc-record filled with default 
+;;      values is returned.
+;;
+;; (netrc:try-parse filename fallback-password fallback-login) -> netrc-record
+;;    parses the netrc file and returns a netrc-record, containing all
+;;    necessary information for the following procedures.
+;;    if there is no file called FILENAME, the according error will be raised
+;;    if the specified file does not have the correct permissions set,
+;;    a netrc-refuse-warning will be signalled.
+;;    so if you don't like the error handling of netrc:parse, use 
+;;    netrc:try-parse and catch the signalled conditions.
+;;
+;; (netrc:lookup netrc-record machine [default?]) -> string x string x string
+;;    Return the login,password,account information for MACHINE
+;;    specified by the netrc file.
+;;    If DEFAULT? is #t, default values are returned if no such
+;;    MACHINE is specified in the netrc file. Otherwise, #f,#f,#f
+;;    is returned
+;;
+;; (netrc:lookup-password netrc-record machine [default?]) -> string
+;;    Return the password information for MACHINE specified by the
+;;    netrc file.
+;;    If DEFAULT? is #t, the default password is returned if no such
+;;    MACHINE is specified. Otherwise, #f is returned.
+;;
+;; (netrc:lookup-login netrc-record machine [default?]) -> string
+;;    Return the login information for MACHINE specified by the
+;;    netrc file.
+;;    If DEFAULT? is #t, the default login is returned if no such
+;;    MACHINE is specified. Otherwise, #f is returned.
+;;
+;; (netrc:default-login netrc-record) -> string
+;;    Return the default login specified by the netrc file or "anonymous"
+;;
+;; (netrc:default-password netrc-record) -> string
+;;    Return the default password specified by the netrc file or
+;;    the mail-addres (result of (user-mail-address))
+
+
+
+;;; Related work ========================================================
+;;
+;; * Graham Barr has written a similar library for Perl, called
+;;   Netrc.pm
+;;
+;; * EFS (transparent remote file access for Emacs) parses the
+;;   user's netrc file
+
+
+;;; Desirable things =============================================
+;;
+;; * Remove restrictions (as stated in 'Overview') and behave like
+;;   /usr/bin/ftp behaves
+;; * perhaps: adding case-insensitivity (for host names)
+;; * perhaps: better record-disclosers for netrc-entry- and netrc-records
+
+
+; return the user's mail address, either specified by the environment
+; variable REPLYTO or "user@hostname".
+(define (user-mail-address)
+  (or (getenv "REPLYTO")
+      (string-append (user-login-name) "@" (system-fqdn))))
+
+
+; looks up the desired machine in a netrc-record
+; if the machine is found in the entries-section
+; following three values are returned: login, password and account
+; if the machine is not found in the entries-section
+; the behavior depends on lookup-default? which defaults to #t:
+; if lookup-default? is #t
+; following three values are returned: default-login default-password #f
+; otherwise #f #f #f is returned.
+(define (netrc:lookup netrc-record machine . lookup-default?)
+  (let-optionals lookup-default?
+		 ((lookup-default? #t))
+    (let ((record (find-record netrc-record machine)))
+      (if record
+	  (values (netrc-entry:login record)
+		  (netrc-entry:password record)
+		  (netrc-entry:account record))
+	  (if lookup-default?
+	      (values (netrc:default-login netrc-record)
+		      (netrc:default-password netrc-record)
+		      #f)
+	      (values #f #f #f))))))
+  
+; does the same as netrc:lookup, but returns only the password (or #f)
+(define (netrc:lookup-password netrc-record machine . lookup-default?)
+  (let-optionals lookup-default?
+		 ((lookup-default? #t))
+    (let ((record (find-record netrc-record machine)))
+      (if record
+	  (netrc-entry:password record)
+	  (and lookup-default?
+	       (netrc:default-password netrc-record))))))
+
+; does the same as netrc:lookup, but returns only the login (or #f)
+(define (netrc:lookup-login netrc-record machine . lookup-default?)
+  (let-optionals lookup-default?
+		 ((lookup-default? #t))
+    (let ((record (find-record netrc-record machine)))
+      (if record
+	  (netrc-entry:login record)
+	  (and lookup-default?
+	       (netrc:default-login netrc-record))))))
+
+; does the work for netrc:parse
+; file-name has to be resolved
+(define (netrc:try-parse file-name default-password default-login)
+  (netrc:check-permissions file-name)
+  (let ((fd (open-input-file file-name))
+	(netrc-record (make-netrc '() default-password default-login file-name)))
+    (for-each-line (parse-line netrc-record) fd)))
+
+; parses the netrc-file
+; expected arguments: filename default-password default-login
+; filename:           filename of the .netrc-file (defaults to ~/.netrc)
+; default-password:   default password for any not specified machine
+;                     defaults to (user-mail-address)
+;                     default password in netrc-file overwrites this setting
+; default-login:      default login name for any not specified machine
+;                     defaults to "anonymous"
+;                     default login in netrc-file overwrites this setting
+; * (default-login is expected after default-password as users usually want
+;   to change the default-password (to something else than their mail-address) 
+;   rather than the login-name)(define (netrc:parse . args)
+; * if the given file does not exist or it has the wrong permissions, 
+;   than a default netrc-record is returned
+; * if you don't want expected errors to be captured, use netrc:try-parse; 
+;   note that you have to resolve the file-name on your own
+(define-condition-type 'netrc-refuse '(warning))
+(define netrc-refuse? (condition-predicate 'netrc-refuse))
+
+(define (netrc:parse . args)
+  (let-optionals 
+   args ((file-name         "~/.netrc")
+	 (default-password  #f)   ; both ... 
+	 (default-login     #f))  ; ... are set if netrc-file does
+					; not provide default-values
+   (let* ((file-name (resolve-file-name file-name))
+	  (local-default-login (lambda () "anonymous"))
+	  (local-default-password (lambda () (user-mail-address)))
+	  (local-default-netrc-record 
+	   (lambda ()
+	     (make-netrc '() 
+			 (or default-login (local-default-login)) 
+			 (or default-password (local-default-password)) 
+			 #f))))
+; i know, this double-handler sucks; has anyone a better idea?
+     (call-with-current-continuation
+      (lambda (exit)
+	(with-handler
+	 (lambda (error more)
+	   (if (netrc-refuse? error)
+	       (format (current-error-port)
+		       "netrc: Warning: ~a~%"
+		       (car (condition-stuff error)))
+	       (format (current-error-port)
+		       "netrc: Warning: Unexpected error encountered: ~s~%"
+		       error))
+	       (exit (local-default-netrc-record)))
+	 (lambda ()
+	   (with-errno-handler*
+	    (lambda (errno packet)
+	      (if (= errno errno/noent)
+		  (format (current-error-port)
+			  "netrc: Warning: no such file or directory: ~a~%"
+			  file-name)
+		  (format (current-error-port)
+			  "netrc: Warning: Error accessing file ~s~%"
+			  file-name))
+		  (exit (local-default-netrc-record)))
+	    (lambda ()
+	      (let ((netrc-record 
+		     (netrc:try-parse file-name default-password default-login)))
+		; If we get a netrc-record, we return it after
+                ; checking default login and default password settings.
+		; Otherwise, we return the default record with
+		; file-name stored.
+                ; This is sub-optimal, as we may throw away badly
+                ; structured .netrc-files silently. We need an error
+                ; checking mechanism.
+		(if (netrc? netrc-record)      
+		    (begin
+		      (if (eq? (netrc:default-login netrc-record) #f)
+			  (set-netrc:default-login (local-default-login)))
+		      (if (eq? (netrc:default-password netrc-record) #f)
+			  (set-netrc:default-password (local-default-password)))
+		      netrc-record)
+		    (let ((default-netrc-record (local-default-netrc-record)))
+		      (set-netrc:file-name default-netrc-record file-name)
+		      default-netrc-record))))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; nothing exported below
+;; except
+;;  netrc:default-password
+;;  netrc:default-login
+
+(define-record netrc-entry
+  machine
+  login
+  password
+  account)
+
+(define-record netrc
+  entries                 ; list of netrc-entrys
+  default-login           ; default-values (either library-default or netrc-file-default)
+  default-password
+  file-name)         ; debug-purpose
+
+
+(define-record-discloser type/netrc-entry
+  (lambda (netrc-entry)
+    (list 'netrc-entry)))    ; perhaps something else later on
+
+(define-record-discloser type/netrc
+  (lambda (netrc)
+    (list 'netrc)))          ; perhaps something else later on
+
+; finds a record in the entries-list of a netrc-record
+; matching the given machine
+; returns the netrc-entry-record if found, otherwise #f
+(define (find-record  netrc-record machine)
+  (find-first (lambda (rec)
+		(and (equal? (netrc-entry:machine rec) machine)   
+		     rec))
+	      (netrc:entries netrc-record)))
+
+
+;; raise error if any permissions are set for group or others.
+(define (netrc:check-permissions file-name)
+  (let ((perms (- (file-mode file-name) 32768)))
+    (if (positive? (bitwise-and #b000111111 perms))
+	(signal 'netrc-refuse 
+		(format #f 
+			"Not parsing ~s (netrc file); dangerous permissions." 
+			file-name)))))
+
+; tries to match target on line and returns the first group,
+; or #f if there is no match
+(define (try-match target line)
+  (let ((match (string-match target line)))
+    (and match
+         (match:substring match 1))))
+
+; parses the default line of the netrc-file
+(define (parse-default netrc-record line)
+  (let ((login (try-match "login[ \t]+([^ \t]+)" line))
+        (password (try-match "password[ \t]+([^ \t]+)" line)))
+    (if login
+        (set-netrc:default-login netrc-record login))
+    (if password
+        (set-netrc:default-password netrc-record password))
+    netrc-record))
+
+; parses a line of the netrc-file
+(define (parse-line netrc-record)
+  (lambda (line)
+    (cond ((string-match "default" line)
+	   (parse-default netrc-record line))
+	  (else
+	   (let ((machine  (try-match "machine[ \t]+([^ \t]+)" line))
+		 (login    (try-match "login[ \t]+([^ \t]+)" line))
+		 (password (try-match "password[ \t]+([^ \t]+)" line))
+		 (account  (try-match "account[ \t]+([^ \t]+)" line)))
+	     (if (or machine login password account)
+		 (add netrc-record machine login password account)
+		 netrc-record)))))) ; return record on empty / wrong lines
+; (This is a workaround. we should give a warning on malicious .netrc
+; files.  As we do not have an error checking system installed yet, we
+; skip these lines silently.)
+
+; adds machine login password account stored in a netrc-entry-record
+; to the entries-list of a netrc-record
+(define (add netrc-record machine login password account)
+  (set-netrc:entries netrc-record 
+		     (cons (make-netrc-entry machine login password account) 
+			   (netrc:entries netrc-record)))
+  netrc-record)
+
+;; for testing
+(define (netrc:dump netrc-record)
+  (format #t "~%--- Dumping ~s contents ---" (netrc:file-name netrc-record))
+  (for-each (lambda (rec)
+              (format #t "~%   machine ~a login ~a password ~a account ~a"
+                      (netrc-entry:machine rec)
+                      (netrc-entry:login rec)
+                      (netrc-entry:password rec)
+                      (netrc-entry:account rec)))
+            (netrc:entries netrc-record))
+  (format #t "~%   default login: ~s" (netrc:default-login netrc-record))
+  (format #t "~%   default password: ~s" (netrc:default-password netrc-record))
+  (format #t "~%--- End of ~s contents ---~%" (netrc:file-name netrc-record)))
+  
+
+; runs proc for each line of fd (line is argument to proc)
+; returns either nothing, if the fd had no line
+; or the value returned by proc called on the last line
+(define (for-each-line proc fd)
+  (let ((line (read-line fd)))
+    (if (not (eof-object? line))
+	(let loop ((last-result (proc line)))
+	  (let ((line (read-line fd)))
+	    (if (not (eof-object? line))
+		(loop (proc line))
+		last-result))))))
+
+; finds first element in l for which pred doesn't return #f
+; returns either #f (no such element found)
+; or the result of the last call to pred
+(define (find-first pred l)
+  (if (null? l) #f
+      (or (pred (car l))
+          (find-first pred (cdr l)))))
+
+;; EOF

scheme/lib/nettime.scm

@@ -0,0 +1,76 @@
+;;; nettime.scm -- obtain the time on remote machines
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1998 by Eric Marsden
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; Overview ========================================================
+;;
+;; Most Unix hosts provide a Daytime service which sends the current
+;; date and time as a human-readable character string. The daytime
+;; service is typically served on port 13 as both TCP and UDP.
+;;
+;; The Time protocol provides a site-independent, machine readable
+;; date and time. A "time" consists of the number of seconds since
+;; midnight on 1st January 1900. The Time service is typically served
+;; on port 37 as TCP and UDP. The idea is that you can confirm your
+;; system's idea of the time by polling several independent sites on
+;; the network.
+
+
+;;; Related work ======================================================
+;;
+;; * Time.pm is a Perl module by Graham Barr
+;; * rfc868 describes the Time protocol
+;; * rfc867 describes the Daytime protocol in all its glory
+;; * for a genuinely useful protocol look at the Network Time Protocol
+;; defined in rfc1305, which allows for the synchronization of clocks
+;; on networked computers.
+
+
+
+;; args host protocol, where host may be an IP number or a fqdn. we
+;; subtract 70 years' worth of seconds at the end, since the time
+;; protocol returns the number of seconds since 1900, whereas Unix
+;; time is since 1970.
+(define (net-time host tcp/udp)
+  (let* ((hst-info (host-info host))
+         (srvc-info (service-info "time" "tcp"))         
+         (sock (socket-connect protocol-family/internet
+                               tcp/udp
+                               (host-info:name hst-info)
+                               (service-info:port srvc-info)))
+         (result (read-integer (socket:inport sock))))
+    (close-socket sock)
+    (- result 2208988800)))
+
+
+(define (net-daytime host tcp/udp)
+  (let* ((hst-info (host-info host))
+         (srvc-info (service-info "daytime" "tcp"))
+         (sock (socket-connect protocol-family/internet
+                               tcp/udp
+                               (host-info:name hst-info)
+                               (service-info:port srvc-info)))
+         (result (read-string 20 (socket:inport sock))))
+    (close-socket sock)
+    result))
+
+
+;; read 4 bytes from fd and build an integer from them
+(define (read-integer fd)
+  (let loop ((accum 0)
+             (remaining 4))
+    (if (zero? remaining)
+        accum
+        (loop (+ (arithmetic-shift accum 8) (read-byte fd))
+              (- remaining 1)))))
+
+;; what about EOF??
+(define (read-byte fd)
+  (char->ascii (read-char fd)))
+
+
+;; EOF

scheme/lib/parse-forms.scm

@@ -1,16 +1,13 @@
 ;;; Code to parse information submitted from HTML forms. -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
 ;;; Copyright (c) 1995 by Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html
 
-;;; Imports and non-R4RS'isms
-;;;	index			(scsh)
-;;;	let-optionals		(let-opt package)
-;;;	receive			(Multiple-value return)
-;;;     unescape-uri
-;;;     map-string		(strings package)
-;;;	?			(cond)
-
 ;;; About HTML forms
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; The form's field data are turned into a single string, of the form
 ;;; The form's field data are turned into a single string, of the form
@@ -45,12 +42,14 @@
 (define (parse-html-form-query q)
   (let ((qlen (string-length q)))
     (let recur ((i 0))
-      (? ((index q #\= i) =>
-          (lambda (j)
-	    (let ((k (or (index q #\& j) qlen)))
-	      (cons (cons (unescape-uri+ q i j)
-			  (unescape-uri+ q (+ j 1) k))
-		    (recur (+ k 1))))))
+      (cond 
+       ((>= i qlen) '())
+       ((string-index q #\= i) =>
+	(lambda (j)
+	  (let ((k (or (string-index q #\& j) qlen)))
+	    (cons (cons (unescape-uri+ q i j)
+			(unescape-uri+ q (+ j 1) k))
+		  (recur (+ k 1))))))
 	 (else '())))))	; BOGUS STRING -- Issue a warning.
 
 

scheme/lib/pop3.scm

@@ -0,0 +1,356 @@
+;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1998 by Eric Marsden
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; Overview ==============================================================
+;;
+;; The POP3 protocol allows access to email on a maildrop server. It
+;; is often used in configurations where users connect from a client
+;; machine which doesn't have a permanent network connection or isn't
+;; always turned on, situations which make local SMTP delivery
+;; impossible. It is the most common form of email access provided by
+;; Internet Service Providers.
+;;
+;; Two types of authentication are commonly used. The first, most
+;; basic type involves sending a user's password in clear over the
+;; network, and should be avoided. Unfortunately many POP3 clients
+;; only implement this basic authentication. The digest authentication
+;; system involves the server sending the client a "challenge" token;
+;; the client encodes this token with the pass phrase and sends the
+;; coded information to the server. This method avoids sending
+;; sensitive information over the network.
+;;
+;; Once connected, a client may request information about the number
+;; and size of the messages waiting on the server, download selected
+;; messages (either their headers or the entire content), and delete
+;; selected messages.
+
+
+;;; Entry points =======================================================
+;;
+;; (pop3-connect [host logfile]) -> connection
+;;    Connect to the maildrop server named HOST. Optionally log the
+;;    conversation with the server to LOGFILE, which will be appended
+;;    to if it exists, and created otherwise. The environment variable
+;;    MAILHOST, if set, will override the value of HOST.
+;;
+;; (pop3-login connection [login password]) -> status
+;;    Log in to the mailhost. If a login and password are not
+;;    provided, they are first searched for in the user's ~/.netrc
+;;    file. USER/PASS authentication will be tried first, and if this
+;;    fails, APOP authentication will be tried.
+;;
+;; (pop3-login/APOP connection login password) -> status
+;;    Log in to the mailhost using APOP authentication.
+;;
+;; (pop3-stat connection) -> integer x integer
+;;    Return the number of messages and the number of bytes waiting in
+;;    the maildrop.
+;;
+;; (pop3-get connection msgid) -> status
+;;    Download message number MSGID from the mailhost. MSGID must be
+;;    positive and less than the number of messages returned by the
+;;    pop3-stat call. The message contents are sent to
+;;    (current-output-port).
+;;
+;; (pop3-headers connection msgid) -> status
+;;    Download the headers of message number MSGID. The data is sent
+;;    to (current-output-port).
+;;
+;; (pop3-last connection) -> integer
+;;    Return the highest accessed message-id number for the current
+;;    session. This isn't in the RFC, but seems to be supported by
+;;    several servers.
+;;
+;; (pop3-delete connection msgid) -> status
+;;    Mark message number MSGID for deletion. The message will not be
+;;    deleted until the client logs out.
+;;
+;; (pop3-reset connection) -> status
+;;    Any messages which have been marked for deletion are unmarked.
+;;
+;; (pop3-quit connection) -> status
+;;    Close the connection with the mailhost.
+
+
+
+;;; Portability ======================================================
+;;
+;; define-record
+;; socket, regexp
+;; signals/handlers
+
+
+;;; Related work =====================================================
+;;
+;; * Emacs is distributed with a C program called movemail which can
+;;   be compiled with support for the POP protocol. There is also an
+;;   Emacs Lisp library called pop3.el by Richard Pieri which includes
+;;   APOP support.
+;;
+;; * Shriram Krishnamurth has written a POP3 library for MzScheme (as
+;;   well as support for the NNTP protocol, for SMTP, ...).
+;;
+;; * Siod (a small-footprint Scheme implementation by George Carette)
+;;   includes support for the POP3 protocol.
+;;
+;; * rfc1939 describes the POP3 protocol.
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Communication is initiated by the client. The server responds to
+;; each request with a status indicator and an explanatory message.
+;; The client starts off by opening a connection to a well known port
+;; on the server machine (typically TCP 110, or 109 on some broken
+;; systems). Messages sent to the server are of the form
+;; 
+;;            CMD [ <space> arg ] <CR> <LF>
+;;
+;; Replies from the server are of the form
+;;
+;;            status [ <space> Informative message ] <CR> <LF>
+;;
+;; where status is either "+OK" or "-ERR". If the server is sending
+;; data (the contents of a message for example), it marks the end of
+;; the data by a line consisting only of a decimal point (thus the
+;; bytes to look out for are <CR><LF>.<CR><LF>. Any lines in the data
+;; starting with a . have an additional . added to the beginning, to
+;; avoid the client thinking that the line marks the end of the
+;; message. The client should therefore replace double decimal points
+;; at the beginning of a line by a single decimal point.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;: [host x logfile] -> connection
+(define (pop3-connect . args)
+  (let-optionals
+      args
+      ((host-arg #f)
+       (logfile #f))
+    (let* ((host (or (getenv "MAILHOST")
+		     host-arg))
+	   (LOG (and logfile
+		     (open-output-file logfile
+				       (if (file-exists? logfile)
+					   (bitwise-ior open/write open/append)
+					   (bitwise-ior open/write open/create))
+				       #o600)))
+	   (hst-info (host-info host))
+	   (hostname (host-info:name hst-info))
+	   (srvc-info (service-info "pop3" "tcp"))
+	   (sock (socket-connect protocol-family/internet
+				 socket-type/stream
+				 hostname
+				 (service-info:port srvc-info)))
+	   (connection (make-pop3-connection hostname
+					     sock
+					     LOG "" "" #f #f)))
+      (pop3-log connection
+		(format #f "~%-- ~a: opened POP3 connection to ~a"
+			;; (date->string (date))
+			"Dummy date"      ; (format-time-zone) is broken in v0.5.1
+			hostname))
+
+      ;; read the challenge the server sends in its welcome banner
+      (let* ((banner (pop3-read-response connection))
+	     (match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner))
+	     (challenge (and match (match:substring match 1))))
+	(set-pop3-connection:challenge connection challenge))
+      
+      connection)))
+
+
+;; first try standard USER/PASS authentication, and switch to APOP
+;; authentication if the server prefers.
+;;: [string x string] -> status
+(define (pop3-login connection . args)
+  (let ((netrc (and (< (length args) 2) (netrc:parse))))
+    (let-optionals 
+	args
+	((login (or (netrc:lookup-login netrc (pop3-connection:host-name connection) #f)
+		    (call-error "must provide a login" pop3-login args)))
+	 (password (or (netrc:lookup-password netrc 
+					      (pop3-connection:host-name connection) #f)
+		       (call-error "must provide a password" pop3-login args))))
+    (with-handler
+     (lambda (result punt)
+       (if (-ERR? result)
+           (if (pop3-connection:challenge connection)
+               (pop3-login/APOP connection login password)
+               (error "login failed"))))
+     (lambda ()
+       (pop3-send-command connection (format #f "USER ~a" login))
+       (pop3-send-command connection (format #f "PASS ~a" password))
+       (set-pop3-connection:login connection login)
+       (set-pop3-connection:password connection password)
+       (set-pop3-connection:state connection 'connected))))))
+
+
+;; Login to the server using APOP authentication (no cleartext
+;; passwords are sent over the network). The server appends a token to
+;; its welcome message, which is built from the server's fully
+;; qualified domain name and a unique serial number. The client
+;; concatenates this token and the pass phrase and applies the MD5
+;; digest algorithm (a one-way hash) to produce a digest. The user
+;; name and the digest are sent to the server to authenticate the
+;; user. The following example comes from the RFC:
+;;
+;;      S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us>
+;;      C: APOP mrose c4c9334bac560ecc979e58001b3e22fb
+;;      S: +OK maildrop has 1 message (369 octets)
+;; 
+;;      In this example, the shared  secret  is  the  string  `tan-
+;;      staaf'.  Hence, the MD5 algorithm is applied to the string
+;; 
+;;         <1896.697170952@dbc.mtview.ca.us>tanstaaf
+;; 
+;;      which produces a digest value of
+;; 
+;;         c4c9334bac560ecc979e58001b3e22fb
+;;         
+;;: connection x string x string -> status
+(define (pop3-login/APOP connection login password)
+  (let* ((key (string-append (pop3-connection:challenge connection)
+                             password))
+         (digest (md5-digest key))
+         (status (pop3-send-command connection
+                                    (format #f "APOP ~a ~a" login digest))))
+  (set-pop3-connection:login connection login)
+  (set-pop3-connection:password connection password)
+  (set-pop3-connection:state connection 'connected)
+  status))
+  
+
+;; return number of messages and number of bytes waiting at the maildrop
+;;: connection -> integer x integer
+(define (pop3-stat connection)
+  (pop3-check-transaction-state connection 'pop3-stat)
+  (let* ((response (pop3-send-command connection "STAT"))
+         (match (regexp-search (rx (posix-string "([0-9]+) ([0-9]+)")) response)))
+    (values (string->number (match:substring match 1))
+            (string->number (match:substring match 2)))))
+
+;; dump the message number MSGID to (current-output-port)
+;;: connection x integer -> status
+(define (pop3-get connection msgid)
+  (pop3-check-transaction-state connection 'pop3-get)
+  (let ((status (pop3-send-command connection (format #f "RETR ~a" msgid))))
+    (pop3-dump (socket:inport (pop3-connection:command-socket connection)))
+    status))
+
+;;: connection x integer -> status
+(define (pop3-headers connection msgid)
+  (pop3-check-transaction-state connection 'pop3-headers)
+  (let ((status (pop3-send-command connection (format #f "TOP ~a 0" msgid))))
+    (pop3-dump (socket:inport (pop3-connection:command-socket connection)))
+    status))
+
+;; Return highest accessed message-id number for the session. This
+;; ain't in the RFC, but seems to be supported by several servers.
+;;: connection -> integer
+(define (pop3-last connection)
+  (pop3-check-transaction-state connection 'pop3-last)
+  (let ((response (pop3-send-command connection "LAST")))
+    (string->number (car ((infix-splitter) response)))))
+
+;; mark the message number MSGID for deletion. Note that the messages
+;; are not truly deleted until the QUIT command is sent, and messages
+;; can be undeleted using the RSET command.
+;;: connection x integer -> status
+(define (pop3-delete connection msgid)
+  (pop3-check-transaction-state connection 'pop3-delete)
+  (pop3-send-command connection (format #f "DELE ~a" msgid)))
+
+
+;; any messages which have been marked for deletion are unmarked
+;;: connection -> status
+(define (pop3-reset connection)
+  (pop3-check-transaction-state connection 'pop3-reset)
+  (pop3-send-command connection "RSET"))
+
+;;: connection -> status
+(define (pop3-quit connection)
+  (pop3-check-transaction-state connection 'pop3-quit)
+  (let ((status (pop3-send-command connection "QUIT")))
+    (close-socket (pop3-connection:command-socket connection))
+    status))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Nothing exported below.
+
+(define-record pop3-connection
+  host-name
+  command-socket
+  logfd
+  login
+  password
+  challenge
+  state)
+
+;; cf /usr/local/src/scheme48-0.49/scheme/rts/condition.scm
+(define-condition-type '-ERR '(error))
+(define -ERR? (condition-predicate '-ERR))
+
+
+(define (pop3-check-transaction-state connection caller)
+  (if (not (eq? (pop3-connection:state connection) 'connected))
+      (call-error "not in transaction state" caller)))
+
+(define (pop3-read-response connection)
+  (let* ((sock (pop3-connection:command-socket connection))
+         (IN (socket:inport sock))
+         (line (read-line IN)))
+    (pop3-log connection (format #f "-> ~a" line))
+    line))
+
+;; this could perhaps be improved
+(define (pop3-handle-response response command)
+  (let ((match (regexp-search (rx (posix-string "^\\+OK(.*)")) response)))
+    (if match 
+	(match:substring match 1)
+        (let ((match2 (regexp-search (rx (posix-string "^-ERR(.*)")) response)))
+	  (if match2
+	      (signal '-ERR (match:substring match2 1) command)
+	      (signal '-ERR response command))))))
+
+
+(define (pop3-log connection line)
+  (let ((LOG (pop3-connection:logfd connection)))
+    (and LOG
+         (write-string line LOG)
+         (write-string "\n" LOG)
+         (force-output LOG))))
+
+(define (pop3-send-command connection command)
+  (let* ((sock (pop3-connection:command-socket connection))
+         (OUT (socket:outport sock)))
+    (write-string command OUT)
+    (write-crlf OUT)
+    (pop3-log connection (format #f "<- ~a" command))
+    (pop3-handle-response (pop3-read-response connection) command)))
+
+
+;; who will write this in Scheme?
+(define (md5-digest str)
+  (car (run/strings (md5sum) (<< ,str))))
+; the name of the program differs among the distributions
+; e.g. in FreeBSD it is called md5
+
+(define (pop3-dump fd)
+  (let loop ((line (read-line fd)))
+       (cond ((and (not (eof-object? line))
+                   (not (equal? line ".\r")))
+              (and (eq? 0 (string-index line #\.)) ; fix byte-stuffed lines
+                   (eq? 1 (string-index line #\. 1))
+                   (set! line (substring line 1 (string-length line))))
+	      (write-string line)
+              (newline)
+	      (loop (read-line fd))))))
+
+;; EOF

scheme/lib/rate-limit.scm

@@ -0,0 +1,63 @@
+;;; Rate limiting -*- Scheme -*-
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 2002 by Mike Sperber.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+(define-record-type rate-limiter :rate-limiter
+  (really-make-rate-limiter simultaneous-requests
+			    access-lock
+			    block-lock
+			    current-requests)
+  rate-limiter?
+  (simultaneous-requests rate-limiter-simultaneous-requests)
+  (access-lock rate-limiter-access-lock)
+  (block-lock rate-limiter-block-lock)
+  (current-requests rate-limiter-current-requests-unsafe
+		    set-rate-limiter-current-requests!))
+
+(define (make-rate-limiter simultaneous-requests)
+  (really-make-rate-limiter simultaneous-requests
+			    (make-lock)
+			    (make-lock)
+			    0))
+
+(define (rate-limit-block rate-limiter)
+  (obtain-lock (rate-limiter-block-lock rate-limiter)))
+
+(define (rate-limit-open rate-limiter)
+  (obtain-lock (rate-limiter-access-lock rate-limiter))
+  (let ((current-requests
+	 (+ 1 (rate-limiter-current-requests-unsafe rate-limiter))))
+    (set-rate-limiter-current-requests! rate-limiter
+					current-requests)
+    (if (>= current-requests
+	    (rate-limiter-simultaneous-requests rate-limiter))
+	(maybe-obtain-lock (rate-limiter-block-lock rate-limiter))
+	(release-lock (rate-limiter-block-lock rate-limiter))))
+  (release-lock (rate-limiter-access-lock rate-limiter)))
+
+(define (rate-limit-close rate-limiter)
+  (obtain-lock (rate-limiter-access-lock rate-limiter))
+  (let ((current-requests
+	 (- (rate-limiter-current-requests-unsafe rate-limiter) 1)))
+    (if (negative? current-requests)
+	(error "rate-limiter: too many close operations"
+	       rate-limiter))
+    (set-rate-limiter-current-requests! rate-limiter
+					current-requests)
+    (if (= current-requests
+	   (- (rate-limiter-simultaneous-requests rate-limiter)
+	      1))
+	;; we just came back into range
+	(release-lock (rate-limiter-block-lock rate-limiter))))
+  (release-lock (rate-limiter-access-lock rate-limiter)))
+
+(define (rate-limiter-current-requests rate-limiter)
+  (obtain-lock (rate-limiter-access-lock rate-limiter))
+  (let ((current-requests
+	 (rate-limiter-current-requests-unsafe rate-limiter)))
+    (release-lock (rate-limiter-access-lock rate-limiter))
+    current-requests))

scheme/lib/rfc822.scm

@@ -1,25 +1,19 @@
-;;; RFC 822 field-parsing code		-*- Scheme -*- 
-;;; Copyright (c) 1995 by Olin Shivers.
-;;; <shivers@lcs.mit.edu>
-;;;
-;;; Imports and non-R4RS'isms
-;;;     downcase-string upcase-string		(string->symbol conversion)
-;;;	read-crlf-line
-;;;	let-optionals, :optional
-;;;	receive values				(MV return)
-;;;     "\r\n" in string for cr/lf
-;;;     ascii->char				(defining the tab char)
-;;;	index
-;;;     join-strings				(reassembling body lines)
-;;;	error
-;;;     ?					(COND)
+;;; RFC 822 field-parsing code
+
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Olin Shivers <shivers@lcs.mit.edu>
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
 
 ;;; RFC 822 is the "Standard for the format of ARPA Internet text messages"
 ;;; -- the document that essentially tells how the fields in email headers
 ;;; (e.g., the Subject: and To: fields) are formatted. This code is for 
-;;; parsing these headers. Here are two pointers to the document:
-;;; 	Emacs/ange	/ftp@ftp.internic.net:/rfc/rfc822.txt
-;;;	URL 		ftp://ftp.internic.net/rfc/rfc822.txt
+;;; parsing these headers.
+
+;;; Here is a pointer to the document:
+;;;    http://www.ietf.org/rfc/rfc0822.txt
+
 ;;; RFC 822 parsing is useful in other contexts as well -- the HTTP protocol
 ;;; uses it, and it tends to pop up here and there.
 ;;;
@@ -73,16 +67,20 @@
 ;;;             printing these field names out, it looks best if you capitalise
 ;;;             them with (CAPITALIZE-STRING (SYMBOL->STRING FIELD-NAME)).
 ;;; - BODY	List of strings which are the field's body, e.g. 
-;;;             ("shivers@lcs.mit.edu"). Each list element is one line from
-;;;             the field's body, so if the field spreads out over three lines,
-;;;             then the body is a list of three strings. The terminating
-;;;             cr/lf's are trimmed from each string.
+;;;             ("shivers@lcs.mit.edu"). Each list element is one line
+;;;             from the field's body, so if the field spreads out
+;;;             over three lines, then the body is a list of three
+;;;             strings. The terminating cr/lf's are trimmed from each
+;;;             string.  A leading space or a leading horizontal tab
+;;;             is also trimmed, but one and only one.
 ;;; When there are no more fields -- EOF or a blank line has terminated the
 ;;; header section -- then the procedure returns [#f #f].
 ;;; 
-;;; The %READ-RFC822-FIELD variant allows you to specify your own read-line
-;;; procedure. The one used by READ-RFC822-FIELD terminates lines with either
-;;; cr/lf or just lf, and it trims the terminator from the line.
+;;; The %READ-RFC822-FIELD variant allows you to specify your own
+;;; read-line procedure. The one used by READ-RFC822-FIELD terminates
+;;; lines with either cr/lf or just lf, and it trims the terminator
+;;; from the line. Your read-line procedure should trim the terminator
+;;; of a line so an empty line is returned just as an empty string.
 
 (define htab (ascii->char 9))
 
@@ -90,8 +88,8 @@
 ;;; so we can compare these things against quoted constants.
 (define string->symbol-pref
   (if (char=? #\a (string-ref (symbol->string 'a) 0))	; Is it #\a or #\A?
-      (lambda (s) (string->symbol (downcase-string s)))
-      (lambda (s) (string->symbol (upcase-string s)))))
+      (lambda (s) (string->symbol (string-map char-downcase s)))
+      (lambda (s) (string->symbol (string-map char-upcase s)))))
 
 (define (read-rfc822-field . maybe-port)
   (let-optionals maybe-port ((port (current-input-port)))
@@ -105,18 +103,20 @@
 
 	(values #f #f)	; Blank line or EOF terminates header text.
 
-	(? ((index line1 #\:) =>	; Find the colon and
-	    (lambda (colon)		; split out field name.
-	      (let ((name (string->symbol-pref (substring line1 0 colon))))
-		;; Read in continuation lines.
-		(let lp ((lines (list (substring line1
-						 (+ colon 1)
-						 (string-length line1)))))
-		  (let ((c (peek-char port))) ; Could return EOF.
-		    (if (or (eqv? c #\space) (eqv? c htab))
-			(lp (cons (read-line port) lines))
-			(values name (reverse lines))))))))
-	   (else (error "Illegal RFC 822 field syntax." line1)))))) ; No :
+	(cond
+	 ((string-index line1 #\:) =>	; Find the colon and
+	  (lambda (colon)		; split out field name.
+	    (let ((name (string->symbol-pref (substring line1 0 colon))))
+	      ;; Read in continuation lines.
+	      (let lp ((lines (list (substring line1
+					       (+ colon 1)
+					       (string-length line1)))))
+		(let ((c (peek-char port))) ; Could return EOF.
+;;;  RFC822: continuous lines has to start with a space or a htab 
+		  (if (or (eqv? c #\space) (eqv? c htab))
+		      (lp (cons (read-line port) lines))
+		      (values name (reverse lines))))))))
+	 (else (error "Illegal RFC 822 field syntax." line1)))))) ; No :
 
 
 ;;; (read-rfc822-headers [port])
@@ -141,17 +141,17 @@
 (define (%read-rfc822-headers read-line port)
   (let lp ((alist '()))
     (receive (field val) (%read-rfc822-field read-line port)
-      (? (field (? ((assq field alist) =>
-		    (lambda (entry)
-		      (set-cdr! entry (cons val (cdr entry)))
-		      (lp alist)))
-		   (else (lp (cons (list field val) alist)))))
-
-	 ;; We are done. Reverse the order of each entry and return.
-	 (else (for-each (lambda (entry)
-			   (set-cdr! entry (reverse (cdr entry))))
-			 alist)
-	       alist)))))
+	     (cond (field (cond ((assq field alist) =>
+				 (lambda (entry)
+				   (set-cdr! entry (cons val (cdr entry)))
+				   (lp alist)))
+				(else (lp (cons (list field val) alist)))))
+		   
+		   ;; We are done. Reverse the order of each entry and return.
+		   (else (for-each (lambda (entry)
+				     (set-cdr! entry (reverse (cdr entry))))
+				   alist)
+			 alist)))))
 		  
 ;;; (rejoin-header-lines alist [separator])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -161,13 +161,13 @@
 ;;; string used to join these elements together; it defaults to a single
 ;;; space " ", but can usefully be "\n" or "\r\n".
 ;;;
-;;; To rejoin a single body list, use scsh's JOIN-STRINGS procedure.
+;;; To rejoin a single body list, use scsh's STRING-JOIN procedure.
 
 (define (rejoin-header-lines alist . maybe-separator)
   (let-optionals maybe-separator ((sep " "))
     (map (lambda (entry)
 	   (cons (car entry)
-		 (map (lambda (body) (join-strings body sep))
+		 (map (lambda (body) (string-join body sep))
 		      (cdr entry))))
 	 alist)))
 
@@ -200,8 +200,16 @@
   (let ((entry (assq name headers)))
     (and entry
 	 (pair? entry)
-	 (join-strings (cadr entry)
-		       (:optional maybe-sep "\n")))))
+	 (string-join (cadr entry)
+		      (:optional maybe-sep "\n")))))
+
+(define (delete-headers headers name)
+  (fold (lambda (entry rest)
+	  (if (eq? (car entry) name)
+	      rest
+	      (cons entry rest)))
+	'()
+	headers))
 
 
 

scheme/lib/smtp.scm

@@ -1,22 +1,12 @@
 ;;; SMTP client code		-*- Scheme -*- 
-;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
-;;; <bdc@ai.mit.edu>, <shivers@lcs.mit.edu>
-;;;
-;;; See rfc821: /ftp@ftp.internic.net:/rfc/rfc821.txt
 
-;;; External dependencies and non-R4RS'isms
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; system-name user-login-name			(for high-level SENDMAIL proc)
-;;; receive values				(MV return)
-;;; write-string read-string/partial 		(scsh I/O procs)
-;;;      force-output
-;;; scsh's socket module		
-;;; :optional
-;;; error
-;;; switchq					(Conditional macro)
-;;; ?						(COND)
-;;; read-crlf-line write-crlf
-;;; \n \r in strings				(Not R4RS)
+;;; This file is part of the Scheme Untergrund Networking package.
+
+;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
+;;; For copyright information, see the file COPYING which comes with
+;;; the distribution.
+
+;;; See rfc821: http://www.ietf.org/rfc/rfc0821.txt
 
 ;;; SMTP protocol procedures tend to return two values:
 ;;; - CODE The integer SMTP reply code returned by server for the transaction.
@@ -39,10 +29,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not a
-;;; useful Internet host name. How do we do that?
-
-;;; (sendmail to-list body [host])
+;;; (send-mail-via-smtp from to-list headers body [host])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Mail message to recipients in list TO-LIST. Message handed off to server
 ;;; running on HOST; default is the local host. Returns two values: code and
@@ -53,70 +40,50 @@
 ;;; that is, for each recipient refused by the server, you get the error
 ;;; data sent back for that guy. The success check is (< code 400).
 ;;;
-;;; BODY is a string or an input port.
+;;; BODY is a list of strings or an input port.
 
-(define (sendmail to-list body . maybe-host)
+(define (send-mail-via-smtp from to-list headers body . maybe-host)
   (call-with-current-continuation
    (lambda (bailout)
-     (let ((local (system-name))
-	   (socket (smtp/open (:optional maybe-host "localhost"))))
-       (receive (code text) (smtp-transactions socket	; Do prologue.
-			      (smtp/helo socket local)
-			      (smtp/mail socket (string-append (user-login-name)
-							       "@" local)))
-	 (if (>= code 400) (values code text) ; error
-
+     (let* ((host (:optional maybe-host "localhost"))
+	    (local (if (string=? host "localhost")
+		       (system-name) ; we don't need any DNS for that
+		       (system-fqdn)))
+	    (socket (smtp/open host)))
+       (receive (code text)
+	   (smtp-transactions/no-close socket ; Do prologue.
+				       (smtp/helo local)
+				       (smtp/mail from))
+	 (if (>= code 400)
+	     (values code text)		; error
 	     ;; Send over recipients and collect the losers.
 	     (let ((losers (filter-map
-			     (lambda (to)
-			       (receive (code text) (smtp/rcpt socket to)
-				 (and (>= code 400) ; Error
-				      (? ((>= 600)
-					  (smtp/quit socket)
-					  (bailout code text))
-					 (else `(,to ,code ,@text))))))
-			     to-list)))
+			    (lambda (to)
+			      (receive (code text) ((smtp/rcpt to) socket)
+				(and (>= code 400) ; Error
+				     (cond ((>= code 600)
+					    (smtp/quit socket)
+					    (bailout code text))
+					   (else `(,to ,code ,@text))))))
+			    to-list)))
 
 	       ;; Send the message body and wrap things up.
 	       (receive (code text) (smtp-transactions socket
-				      (smtp/data socket body)
-				      (smtp/quit socket))
+						       (smtp/data headers body))
 		 (if (and (< code 400) (null? losers))
 		     (values code text)
 		     (values 700 losers))))))))))
 
-;;; Trivial utility -- like map, but filter out #f's.
-
-(define (filter-map f lis)
-  (let lp ((ans '()) (lis lis))
-    (if (pair? lis)
-	(lp (? ((f (car lis)) => (lambda (val) (cons val ans)))
-	       (else ans))
-	    (cdr lis))
-	(reverse ans))))
-
-(define (%sendmail from local-host to dest-host message)
-  (let ((socket (smtp/open dest-host)))
-    (smtp-transactions socket
-      (smtp/helo socket local-host)
-      (smtp/mail socket from)
-      (smtp/rcpt socket to)
-      (smtp/data socket message)
-      (smtp/quit socket))))
-
-
 ;;; EXPN, VRFY, MAIL-HELP
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; These three are simple queries of the server.
 
 (define (smtp-query socket query arg)
   (receive (code text)
-	     (smtp-transactions socket
-               (smtp/helo socket (system-name))
-	       (query socket arg))
-      (if (not (or (= code 421) (= code 221)))
-	  (smtp/quit socket))
-      (values code text)))
+      (smtp-transactions socket
+			 (smtp/helo (system-name))
+			 (query arg))
+    (values code text)))
 
 (define (expn name host)
   (smtp-query (smtp/open host) smtp/expn name))
@@ -125,13 +92,13 @@
   (smtp-query (smtp/open host) smtp/vrfy name))
 
 (define (mail-help host . details)
-  (smtp-query (smtp/open host) smtp/help (apply string-append details)))
+  (smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details))))
 
 
-;;; (smtp-transactions socket ?transaction1 ...)
-;;; (smtp-transactions/no-close socket ?transaction1 ...)
+;;; (smtp-transactions socket transaction1 ...)
+;;; (smtp-transactions/no-close socket transaction1 ...)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; These macros make it easy to do simple sequences of SMTP commands.
+;;; These procedures make it easy to do simple sequences of SMTP commands.
 ;;;
 ;;; Evaluate a series of expressions ?transaction1, ?transaction2, ...
 ;;; - Each expression should perform an SMTP transaction, 
@@ -140,7 +107,7 @@
 ;;;   + TEXT (list of strings that came with the reply).
 ;;;
 ;;; - If the transaction's reply code is 221 or 421 (meaning the socket has
-;;;   been closed), then the transaction sequence is is aborted, and the
+;;;   been closed), then the transaction sequence is aborted, and the
 ;;;   SMTP-TRANSACTIONS form returns the CODE and TEXT values for the current
 ;;;   transaction.
 ;;;
@@ -155,9 +122,7 @@
 ;;; - Otherwise, we throw away the current CODE and TEXT values, and
 ;;;   proceed to the next transaction.
 ;;;
-;;; Since SMTP-TRANSACTIONS closes the socket whenever it aborts a sequence,
-;;; an SMTP-TRANSACTIONS form terminated with an (smtp/quit socket) transaction
-;;; will always close the socket.
+;;; SMTP-TRANSACTIONS closes the socket after the transaction.
 ;;;
 ;;; If the socket should be kept open in the case of an abort, use
 ;;; SMTP-TRANSACTIONS/NO-CLOSE.
@@ -168,59 +133,25 @@
 ;;; than proceeding to mail the other four. This may not be what you want;
 ;;; if so, you'll have to roll your own.
 
-(define-syntax smtp-transactions 
-  (syntax-rules ()
-    ((smtp-transactions socket ?T1 ?T2 ...)
-     (let ((s socket))
-       (receive (code text) (smtp-transactions/no-close s ?T1 ?T2 ...)
-	 (if (<= 400 code) (smtp/quit s))
-	 (values code text))))))
-
-(define-syntax smtp-transactions/no-close
-  (syntax-rules ()
-    ((smtp-transactions/no-close socket ?T1 ?T2 ...)
-     ;; %smtp-transactions/no-close replicates the socket argument, 
-     ;; so we have to force it to be a variable.
-     (let ((s socket))
-       (%smtp-transactions/no-close s ?T1 ?T2 ...)))))
-
-;;; SOCKET must be a variable, hence replicable.
-(define-syntax %smtp-transactions/no-close
-  (syntax-rules ()
-    ((%smtp-transactions/no-close socket ?T1 ?T2 ?T3 ...)
-     (receive (code text) ?T1
-       (if (or (= code 221)
-	       (= code 421)		; Redundant, I know.
-	       (<= 400 code))
-	   (values code text)
-	   (%smtp-transactions/no-close socket ?T2 ?T3 ...))))
-
-    ((%smtp-transactions/no-close socket ?T1)
-     ?T1)))
-
-;;; I can't make this nested definition work. I'm not enough of a macro stud.
-;(define-syntax smtp-transactions/no-close
-;  (syntax-rules ()
-;    ((smtp-transactions/no-close socket ?T1 ...)
-;     (letrec-syntax ((%smtp-transactions/no-close
-;		      (syntax-rules ()
-;
-;		        ((%smtp-transactions/no-close socket ?T1 ?T2 ...)
-;			 (receive (code text) ?T1
-;			   (if (or (= code 221)
-;				   (= code 421)		; Redundant, I know.
-;				   (<= 400 code))
-;			       (values code text)
-;			       (%smtp-transactions/no-close socket ?T2 ...))))
-;
-;			((%smtp-transactions/no-close socket ?T1)
-;			 ?T1))))
-;
-;       ;; %smtp-transactions/no-close replicates the socket argument, 
-;       ;; so we have to force it to be a variable.
-;       (let ((s socket))
-;	 (%smtp-transactions/no-close s ?T1 ...))))))
+(define (smtp-transactions socket . transactions)
+  (receive (code text) (apply smtp-transactions/no-close socket transactions)
+    (cond
+     ((or (= code 221)
+	  (= code 421))
+      (values))
+     (else
+      (smtp/quit socket)))
+    (values code text)))
 
+(define (smtp-transactions/no-close socket . transactions)
+  (let loop ((transactions transactions))
+    (receive (code text) ((car transactions) socket)
+      (if (or (null? (cdr transactions))
+	      (= code 221)
+	      (= code 421)		; Redundant, I know.
+	      (<= 400 code))
+	  (values code text)
+	  (loop (cdr transactions))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; The basics of the protocol
@@ -228,26 +159,27 @@
 (define (nullary-smtp-command command)
   (lambda (socket)
     (let ((port (socket:outport socket)))
-       (write-string command port)
-       (write-crlf port))
+      (write-string command port)
+      (write-crlf port))
     (handle-smtp-reply socket)))
 
-
 (define (unary-smtp-command command)
-  (lambda (socket data)
-    (let ((port (socket:outport socket)))
-       (write-string command port)
-       (display      #\space port)
-       (write-string data    port)
-       (write-crlf           port))
-    (handle-smtp-reply socket)))
+  (lambda (data)
+    (lambda (socket)
+      (let ((port (socket:outport socket)))
+	(write-string command port)
+	(display      #\space port)
+	(write-string data    port)
+	(write-crlf           port))
+      (handle-smtp-reply socket))))
 
 
 (define (smtp/open host . maybe-port)
   (let ((sock (socket-connect protocol-family/internet socket-type/stream host
 			      (:optional maybe-port "smtp"))))
     (receive (code text) (handle-smtp-reply sock)
-      (if (< code 400) sock
+      (if (< code 400)
+	  sock
 	  (error "SMTP socket-open server-reply error" sock code text)))))
 
 ;; HELLO <local-hostname>
@@ -262,31 +194,50 @@
 ;; DATA
 (define smtp/data
   (let ((send-DATA-msg (nullary-smtp-command "DATA")))
-    (lambda (socket message)  ; MESSAGE is a string or an input port.
-      (receive (code text) (send-DATA-msg socket)
-	(if (>= code 400) (values code text) ; Error.
+    (lambda (headers message)		; MESSAGE is a list of strings or an input port.
+      (lambda (socket)
+	(receive (code text) (send-DATA-msg socket)
+	  (if (>= code 400)
+	      (values code text)	; Error.
 
-	    ;; We got a positive acknowledgement for the DATA msg,
-	    ;; now send the message body.
-	    (let ((p (socket:outport socket)))
-	      (? ((string? message)
-		  (receive (data last-char) (smtp-stuff message #f)
-		    (write-string data p)))
-	
-		 ((input-port? message)
-		  (let lp ((last-char #f))
-		    (? ((read-string/partial 1024 message) =>
-			(lambda (chunk)
-			  (receive (data last-char)
-			      (smtp-stuff chunk last-char)
-			    (write-string data p)
-			    (lp last-char)))))))
+	      ;; We got a positive acknowledgement for the DATA msg,
+	      ;; now send the message body.
+	      (let ((p (socket:outport socket)))
+		(for-each (lambda (pair)
+			    (display (car pair) p)
+			    (write-char #\: p)
+			    (display (cdr pair) p)
+			    (write-crlf p))
+			  headers)
+		(write-crlf p)
+		
+		(cond ((or (null? message) (pair? message))
+		       (for-each (lambda (line)
+				   (write-data-line line p))
+				 message))
+		    
+		      ((input-port? message)
+		       (let lp ()
+			 (let ((stuff (read-line message)))
+			   (if (not (eof-object? stuff))
+			       (begin
+				 (write-data-line stuff p)
+				 (newline))))))
+		    
+		      (else (error "Message must be string or input-port.")))
 
-		 (else (error "Message must be string or input-port.")))
+		(write-crlf p)
+		(write-char #\. p)
+		(write-crlf p)
+		(force-output p)
+		(handle-smtp-reply socket))))))))
 
-	      (write-string "\r\n.\r\n" p)
-	      (force-output p)
-	      (handle-smtp-reply socket)))))))
+(define (write-data-line line port)
+  (display (if (string=? line ".")
+	       ".."
+	       line)
+	   port)
+  (write-crlf port))
 
 ;; SEND FROM: <sender-address>
 (define smtp/send (unary-smtp-command "SEND FROM:"))
@@ -309,8 +260,8 @@
 ;; HELP <details>
 (define smtp/help
   (let ((send-help (unary-smtp-command "HELP")))
-    (lambda (socket . details)
-      (send-help socket (apply string-append details)))))
+    (lambda details
+      (send-help (apply string-append details)))))
 
 ;; NOOP
 (define smtp/noop (nullary-smtp-command "NOOP"))
@@ -319,10 +270,10 @@
 (define smtp/quit
   (let ((quit (nullary-smtp-command "QUIT")))
     (lambda (socket)
-      (receive (code text) (quit socket)    ; Quit & close socket gracefully.
-	(switchq = code		
+      (receive (code text) (quit socket) ; Quit & close socket gracefully.
+	(case code		
 	  ((221 421))
-	  (else (close-socket socket)))	    ; But close in any event.
+	  (else (close-socket socket))) ; But close in any event.
 	(values code text)))))
 
 ;; TURN
@@ -339,8 +290,8 @@
 
 (define (handle-smtp-reply socket)
   (receive (code text) (read-smtp-reply (socket:inport socket))
-    (switchq = code
-      ((221 421) (close-socket socket)))	; All done.
+    (case code
+      ((221 421) (close-socket socket))) ; All done.
     (values code text)))
 
 ;;; Read a reply from the SMTP server. Returns two values:
@@ -362,7 +313,8 @@
 			    (reverse replies)))
 	  (receive (code line more?) (parse-smtp-reply ln)
 	    (let ((replies (cons line replies)))
-	      (if more? (lp replies)
+	      (if more?
+		  (lp replies)
 		  (values code (reverse replies)))))))))
 
 ;;; Parse a line of SMTP reply. Return three values:
@@ -388,49 +340,6 @@
 	      (string-append "Improperly-formatted smtp reply: " line)
 	      #f)))
 
-
-;;; The message body of a piece of email is terminated by the sequence 
-;;;     <crlf> <period> <crlf>
-;;; If the message body contains this magic sequence, it has to be escaped.
-;;; We do this by mapping the sequence <lf> <period> to <lf> <period> <period>;
-;;; the SMTP receiver undoes this mapping.
-
-;;; S is a string to stuff, PCHAR was the character read just before S
-;;; (which matters if it is a line-feed). If S is the first chunk of the entire
-;;; msg, then PCHAR can be #f. Return two values: the stuffed string, and the
-;;; last char in S (or PCHAR if S is empty). The last-char value returned can
-;;; be used as the PCHAR arg for the following call to SMTP-STUFF.
-
-(define (smtp-stuff s pchar)
-  (let* ((slen (string-length s))
-	 (hits ; Count up all the <lf> <period> seqs in the string.
-	  (let lp ((count 0)
-		   (nl? (eqv? pchar #\newline))	; Was last char a newline?
-		   (i 0))
-	    (if (< i slen)
-		(let ((c (string-ref s i)))
-		  (lp (if (and nl? (char=? c #\.)) (+ count 1) count)
-		      (eq? c #\newline)
-		      (+ i 1)))
-		count))))
-
-    (values (if (zero? hits) s
-		;; Make a new string, and do the dot-stuffing copy.
-		(let ((ns (make-string (+ hits slen))))
-		  (let lp ((nl? (eqv? pchar #\newline))
-			   (i 0)	; S index.
-			   (j 0))	; NS index.
-		    (if (< i slen)
-			(let ((c (string-ref s i)))
-			  (string-set! ns j c)
-			  (? ((and nl? (char=? c #\.))
-			      (string-set! ns (+ j 1) #\.)
-			      (lp #f (+ i 1) (+ j 2)))
-			     (else (lp (char=? c #\newline) (+ i 1) (+ j 1)))))))
-		  ns))
-
-	    (if (zero? slen) pchar (string-ref s (- slen 1))))))    ; LAST-CHAR
-
 ;;; Reply codes
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; This material taken from the RFC.

scheme/lib/sunet-utilities.scm

@@ -0,0 +1,70 @@
+; some useful utilities
+
+;;; 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.
+
+(define (host-name-or-ip addr)
+  (with-fatal-error-handler
+   (lambda (condition more)
+     (call-with-values
+      (lambda () (socket-address->internet-address addr))
+      (lambda (ip port)
+	(format-internet-host-address ip))))
+   (host-info:name (host-info addr))))
+
+(define (on-interrupt interrupt thunk)
+  (let lp ((event (most-recent-sigevent)))
+    (let ((next (next-sigevent event interrupt)))
+      (thunk)
+      (lp next))))
+
+(define (socket-address->string socket-address . with-port?)
+  (let ((with-port? (:optional with-port? #t)))
+    (receive (host-address service-port)
+	     (socket-address->internet-address socket-address)
+	     (if with-port?
+		 (format #f "~A:~A"
+			 (format-internet-host-address host-address)
+			 (format-port service-port))
+		 (format #f "~A"
+			 (format-internet-host-address host-address))))))
+
+
+(define (system-fqdn)
+  (let ((host (host-info (system-name))))
+    (let loop ((addresses (host-info:addresses host)))
+      (if (null? addresses)
+	  #f
+	  (or (dns-lookup-ip (car addresses))
+	      (loop (cdr addresses)))))))
+
+;;; Assemble a filename from ROOT and the elts of PATH-LIST.
+;;; If the assembled filename contains a .. subdirectory, return #f,
+;;; otw return the filename.
+
+(define dotdot-check
+  (let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)")))	; Matches a .. subdir.
+    (lambda (root path-list)
+      (let ((fname (if (null? path-list) root	; Bogus hack.
+		       (string-append (file-name-as-directory root)
+				      (string-join path-list "/")))))
+	(and (not (regexp-exec dotdot-re fname))	; Check for .. subdir.
+	     fname)))))
+
+;;; Timeout on network writes?
+
+(define (copy-inport->outport in out . maybe-buffer-size)
+  (let* ((buffer-size (:optional maybe-buffer-size 1024))
+	 (buf (make-string buffer-size)))
+    (let loop ()
+      (cond ((read-string! buf in) => (lambda (nchars)
+					(write-string buf out 0 nchars)
+					(loop)))))
+    (force-output out)))
+
+(define (dump fd)
+  (copy-inport->outport fd (current-output-port)))
+

scheme/lib/uri.scm

@@ -1,22 +1,15 @@
 ;;; -*- 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.
 
 ;;; URI syntax -- [scheme] : path [? search ] [# fragmentid]
 
-;;; Imports and non-R4RS'isms
-;;;	let-optionals
-;;;	receive values				(MV return)
-;;;     ascii->char char->ascii			
-;;;	index rindex
-;;;	char-set-index char-set-rindex
-;;;	string-reduce
-;;;	char-set package
-;;;	bitwise logical funs and arithmetic-shift
-;;; 	join-strings				(scsh field-reader code.)
-
-
 ;;; References:
-;;; - ftp://ftp.internic.net/rfc/rfc1630.txt 
+;;; - 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.
@@ -44,31 +37,38 @@
 ;;;   If it's a question-mark, then that's the <search> part -- remove it.
 ;;; - What's left is the path. Split at slashes. "" -> ("")
 ;;;
-;;; This scheme is tolerant of the various ways people build broken URI's
-;;; out there on the Net. It was given to me by Dan Connolly of the W3C.
+;;; This scheme is tolerant of the various ways people build broken
+;;; URI's out there on the Net , p.e. \#= is a reserved character, but
+;;; used unescaped in the search-part. It was given to me by Dan
+;;; Connolly of the W3C and slightly modified.
 
-;;; Returns four values: scheme, path, search, frag-id.
-;;; Each value is either #f or a string.
+;;; Returns four values: scheme, path, search, frag-id.  Each value is
+;;; either #f or a string except of the path, which is a nonempty list
+;;; of string (as mentioned above).
 
-(define uri-reserved (string->char-set "=;/#?: "))
+
+(define uri-reserved (string->char-set ";/#?: ="))
 
 (define (parse-uri s)
   (let* ((slen (string-length s))
 	 ;; Search forwards for colon (or intervening reserved char).
-	 (rs1 (char-set-index s uri-reserved))	; 1st 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))
 
 	 ;; Search backwards for # (or intervening reserved char).
-	 (rs-last (char-set-rindex s uri-reserved))
+	 (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).
-	 (rs-penult (if sharp (char-set-rindex s uri-reserved sharp) rs-last))
+	 ;; (NB: #\= may be after #\? and before #\#)
+	 (rs-penult (string-index-right
+		     s                      
+		     (char-set-delete uri-reserved #\=)
+		     (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-path s path-start path-end)
 	    (and ques (substring s (+ ques 1) (or sharp slen)))
@@ -95,20 +95,25 @@
 	 
       (if (and (zero? hits) (zero? start) (= end (string-length s))) s
 
-	  (let* ((nlen (- (- end start) (* hits 2)))
-		 (ns (make-string nlen)))
+	  (let* ((nlen (- (- end start) (* hits 2)))   ; the new
+						       ; length of the
+						       ; unescaped
+						       ; string
+		 (ns (make-string nlen)))              ; stores the result
 
-	    (let lp ((i start) (j 0))
+	    (let lp ((i start) (j 0))                  ; sweap over the string
 	      (if (< j nlen)
-		  (lp (? ((esc-seq? i)
-			  (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)))
+		  (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)))))
 
@@ -116,10 +121,11 @@
   (let ((hex-digits (string->char-set "0123456789abcdefABCDEF")))
     (lambda (c) (char-set-contains? hex-digits c))))
 
-(define (hexchar->int c)
+; make use of the fact that numbers and characters are in order in the ascii table
+(define (hexchar->int c)      
   (- (char->ascii c) 
      (if (char-numeric? c)
-	 (char->ascii #\0)
+	 (char->ascii #\0)         
 	 (- (if (char-upper-case? c)
 		(char->ascii #\A)
 		(char->ascii #\a))
@@ -140,37 +146,42 @@
 ;;; slashes and colons would be escaped.
 
 (define uri-escaped-chars
-  (char-set-invert (char-set-union char-set:alphanumeric
-				   (string->char-set "$-_@.&!*\"'(),+"))))
+  (char-set-complement (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-reduce 0
-			       (lambda (c i)
-				 (+ i
-				    (if (char-set-contains? uri-escaped-chars c)
-					3 1)))
-			       s)))
+    (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-reduce
+	  (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
-	     (lambda (c i)
-	       (+ i (? ((char-set-contains? uri-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))))
 	     s)
 	    ns)))))
 
@@ -198,20 +209,21 @@
 		     (rhead '())			; CP prefix, reversed.
 		     (j 0))				; J counts sequential /
 	      
-	      (? ((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
-		  (lp (cdr cp-tail)
-		      (cons (car cp-tail) rhead)
-		      (+ j 0)))
+	      (cond
+	       ((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
+		(lp (cdr cp-tail)
+		    (cons (car cp-tail) rhead)
+		    (+ j 0)))
 
-		 ((= j numsl)				; Win
-		  (values cscheme (simplify-uri-path (rev-append rhead p))))
+	       ((= j numsl)				; Win
+		(values cscheme (simplify-uri-path (rev-append rhead p))))
 
-		 ((pair? cp-tail)				; Keep looking.
-		  (lp (cdr cp-tail)
-		      (cons (car cp-tail) rhead)
-		      1))
+	       ((pair? cp-tail)				; Keep looking.
+		(lp (cdr cp-tail)
+		    (cons (car cp-tail) rhead)
+		    1))
 
-		 (else (values #f #f)))))		; Lose.
+	       (else (values #f #f)))))		; Lose.
 
 
 	  ;; P doesn't begin with a slash.
@@ -230,12 +242,13 @@
 
 (define (split-uri-path uri start end)		; Split at /'s (infix grammar).
   (let split ((i start))			; "" -> ("")
-    (? ((>= i end) '(""))
-       ((index uri #\/ i) =>
-	(lambda (slash)
-	  (cons (substring uri i slash)
-		(split (+ slash 1)))))
-       (else (list (substring uri i end))))))
+    (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.
@@ -243,36 +256,39 @@
 ;;;     (uri-path-list->path (map escape-uri pathlist))
 
 (define (uri-path-list->path plist)
-  (join-strings plist "/"))		; Insert slashes between elts of PLIST.
+  (string-join plist "/"))		; Insert slashes between elts of PLIST.
 
 
-;;; Remove . and foo/.. elts from path. After simplification, there are no
-;;; . elements, and the only .. elements occur at the beginning of the path
-;;; (i.e., they attempt to back up past root). One could argue that this is
-;;; illegal, and we should error out in this case, reporting an unresolvable
-;;; URL. The URI "spec" is not even slightly clear on this issue.
-;;;
-;;; URI's are pathetic. The case of /a/b//../c is ambiguous. Do we
-;;; 	1) not simplify across multi-slashes?
-;;; 	2) Flush the "empty" dir, giving /a/b//c
-;;;	3) Flush across multi-slashes, giving /a/c
-;;; What is the meaning of //../a ? /../b ? /../../c ?
+;;; Remove . and <segment>/.. elements from path.  The result is a
+;;; (maybe empty) list representing a path that does not contain "." 
+;;; and ".." elements neither at the beginning nor somewhere else. I
+;;; tried to follow RFC2396 here. The procedure returns #f if the path
+;;; tries to back up past root (like "//.." or "/foo/../.."). "//" may
+;;; occur somewhere in the path but not being backed up. Usually,
+;;; relative paths are intended to be used with a base
+;;; url. Accordingly to RFC2396 (as I hope) relative paths are
+;;; considered not to start with "/". 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 "/").
 
-(define (simplify-uri-path p)	; P must be non-null.
-  (reverse (let lp ((path-list p)
-		    (ans '()))
-	     (let ((elt (car path-list))
-		   (path-list (cdr path-list)))
-	       (? ((pair? path-list)
-		   (? ((string=? "." elt) ; Kill .
-		       (lp path-list ans))
-		      ((string=? ".." elt)
-		       (if (pair? ans)
-			   (lp path-list (cddr ans))
-			   (lp path-list (cons elt ans))))
-		      (else
-		       (lp path-list (cons elt ans)))))
-		  ;; Last element of list.
-		  ((string=? ".." elt)
-		   (if (null? ans) '("..") (cddr ans)))
-		  (else (cons elt ans)))))))
+(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))))))))
+	  
+ 

scheme/lib/url.scm

@@ -1,10 +1,15 @@
 ;;; URL 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:
-;;; - ftp://ftp.internic.net/rfc/rfc1738.txt 
+;;; - 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.
@@ -14,12 +19,6 @@
 ;;; - The userhost parser shouldn't substitute default values --
 ;;;   that should happen in a separate step.
 
-;;; Imports and non-R4RS'isms
-;;; 	define-record		Record structures
-;;; 	receive values		MV return
-;;; 	URI support
-;;; 	index
-
 ;;; 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.
@@ -38,10 +37,11 @@
   host
   port)
 
-;;; Parse a URI path into a userhost record. Default values are taken
-;;; from the userhost record DEFAULT. Returns a userhost record if it
-;;; wins, and #f if it cannot parse the path. CDDDR drops the userhost
-;;; portion of the path.
+;;; Parse a URI path (a list representing a path, not a string!) into
+;;; a userhost record. Default values are taken from the userhost
+;;; record DEFAULT except for the host. Returns a userhost record if
+;;; it wins. CADDR drops the userhost portion of the path. In fact,
+;;; fatal-syntax-error is called, if the path doesn't start with '//'.
 
 (define (parse-userhost path default)
   (if (and (pair? path)				; The thing better begin
@@ -52,12 +52,12 @@
       (let* ((uhs (caddr path))			; Userhost string.
 	     (uhs-len (string-length uhs))
 							; Usr:passwd at-sign,
-	     (at (index uhs #\@))			;     if any.
+	     (at (string-index uhs #\@))			;     if any.
 	       
-	     (colon1 (and at (index uhs #\:)))		    ; Usr:passwd colon,
+	     (colon1 (and at (string-index uhs #\:)))		    ; Usr:passwd colon,
 	     (colon1 (and colon1 (< colon1 at) colon1))	    ;     if any.
 
-	     (colon2 (index uhs #\: (or at 0))))	; Host:port colon,
+	     (colon2 (string-index uhs #\: (or at 0))))	; Host:port colon,
 	      						;     if any.
 	(make-userhost (if at
 			   (unescape-uri uhs 0 (or colon1 at))
@@ -110,17 +110,18 @@
   search
   frag-id)
 
-;;; The URI parser 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 (or #f if the string cannot be parsed). All strings
-;;; come back from the URI parser encoded. SEARCH and FRAG-ID are left
-;;; that way; this parser decodes the path elements.
+;;; 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.
 ;;;
-;;; Return #f if the URL could not be parsed.
+;;; Returns a HTTP-URL record, if possible. Otherwise
+;;; FATAL-SYNTAX-ERROR is called.
 
 (define (parse-http-url path search frag-id)
   (let ((uh (parse-userhost path default-http-userhost)))
@@ -142,9 +143,9 @@
 		 (userhost->string (http-url:userhost url))
 		 "/"
 		 (uri-path-list->path (map escape-uri (http-url:path url)))
-		 (? ((http-url:search url) =>
-                     (lambda (s) (string-append "?" s)))
-		    (else ""))
-		 (? ((http-url:frag-id url) =>
-                     (lambda (fi) (string-append "#" fi)))
-		    (else ""))))
+		 (cond ((http-url:search url) =>
+			(lambda (s) (string-append "?" s)))
+		       (else ""))
+		 (cond ((http-url:frag-id url) =>
+			(lambda (fi) (string-append "#" fi)))
+		       (else ""))))

scheme/packages.scm

@@ -0,0 +1,914 @@
+;; Scheme 48 package definitions for the
+;; Scheme Untergrund Networking Suite
+
+;;; 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.
+
+;; Interfaces
+
+;; Net protocols and formats
+ 
+(define-interface parse-html-forms-interface
+  (export parse-html-form-query unescape-uri+))
+
+(define-interface htmlout-interface
+  (export emit-tag
+	  emit-close-tag
+
+	  emit-p
+	  emit-title	
+	  emit-header	; And so forth...
+
+	  with-tag
+	  with-tag*
+
+	  escape-html
+	  emit-text))
+
+(define-interface smtp-interface
+  (export send-mail-via-smtp
+	  expn vrfy mail-help
+	  smtp-transactions
+	  smtp-transactions/no-close
+	  smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
+	  smtp/send smtp/soml smtp/saml smtp/rset smtp/expn
+	  smtp/help smtp/noop smtp/quit smtp/turn))
+
+(define-interface rfc822-interface
+  (export read-rfc822-headers
+	  read-rfc822-field
+	  %read-rfc822-headers
+	  %read-rfc822-field
+	  rejoin-header-lines
+	  get-header-all
+	  get-header-lines
+	  get-header
+	  delete-headers
+	  ))
+
+(define-interface uri-interface 
+  (export parse-uri
+	  uri-escaped-chars
+	  unescape-uri
+	  escape-uri
+	  resolve-uri
+	  split-uri-path
+	  uri-path-list->path
+	  simplify-uri-path))
+
+(define-interface url-interface
+  (export userhost?		; USERHOST
+	  make-userhost		; record struct
+
+	  userhost:user
+	  userhost:password
+	  userhost:host
+	  userhost:port
+
+	  set-userhost:user
+	  set-userhost:password
+	  set-userhost:host
+	  set-userhost:port
+	  
+	  parse-userhost	; parse &
+	  userhost->string	; unparse.
+
+	  http-url?		; HTTP-URL
+	  make-http-url		; record struct
+
+	  http-url:userhost
+	  http-url:path
+	  http-url:search
+	  http-url:frag-id
+
+	  set-http-url:userhost
+	  set-http-url:path
+	  set-http-url:search
+	  set-http-url:frag-id
+	  
+	  parse-http-url	; parse &
+	  http-url->string))
+
+(define-interface ftp-interface
+  (export ftp-connect
+          ftp-login
+          ftp-type
+          ftp-rename
+          ftp-delete
+          ftp-cd
+          ftp-cdup
+          ftp-pwd
+          ftp-rmdir
+          ftp-mkdir
+          ftp-modification-time
+          ftp-size
+          ftp-abort
+          ftp-quit
+          ftp-ls
+          ftp-dir          
+          ftp-get
+          ftp-put
+          ftp-append
+          ftp-quot
+	  ftp-error?))
+
+(define-interface ftp-obsolete-interface
+  (export ftp:connect
+          ftp:login
+          ftp:type
+          ftp:rename
+          ftp:delete
+          ftp:cd
+          ftp:cdup
+          ftp:pwd
+          ftp:rmdir
+          ftp:mkdir
+          ftp:modification-time
+          ftp:size
+          ftp:abort
+          ftp:quit
+          ftp:ls
+          ftp:dir          
+          ftp:get
+          ftp:put
+          ftp:append
+          ftp:quot))
+
+(define-interface netrc-interface 
+  (export user-mail-address
+          netrc:lookup
+          netrc:lookup-password
+          netrc:lookup-login
+          netrc:parse
+	  netrc:try-parse
+	  netrc-refuse?))
+
+(define-interface pop3-interface
+  (export pop3-connect
+          pop3-login
+          pop3-stat
+          pop3-get
+          pop3-headers
+          pop3-last
+          pop3-delete
+          pop3-reset
+          pop3-quit))
+
+(define-interface pop3-obsolete-interface
+  (export pop3:connect
+          pop3:login
+          pop3:stat
+          pop3:get
+          pop3:headers
+          pop3:last
+          pop3:delete
+          pop3:reset
+          pop3:quit))
+
+(define-interface nettime-interface
+  (export net-time
+          net-daytime))
+
+(define-interface nettime-obsolete-interface
+  (export net:time
+	  net:daytime))
+
+(define-interface dns-interface
+  (export dns-clear-cache		; clears the cache
+	  dns-lookup			; complex lookup function
+	  dns-lookup-name		; simple lookup function
+	  dns-inverse-lookup		; obsolete, use dns-lookup-ip
+	  dns-lookup-ip			; simple lookup function
+	  dns-lookup-nameserver		; simple lookup function
+	  dns-lookup-mail-exchanger	; simple lookpu function
+	  show-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
+	  address32->ip-string		; converts a address32 in an ip-string
+	  ip-string->address32		; converts a ip-string in an address32
+	  dns-find-nameserver		; returns a nameserver
+	  dns-find-nameserver-list	; returns a list of nameservers
+	  socket-address->fqdn
+	  internet-address->fqdn
+	  host-fqdn
+	  system-fqdn))
+
+(define-interface cgi-script-interface
+  (export cgi-form-query))
+
+;; Utility libraries
+
+(define-interface rate-limit-interface
+  (export make-rate-limiter
+	  rate-limit-block
+	  rate-limit-open
+	  rate-limit-close
+	  rate-limiter-current-requests))
+
+(define-interface crlf-io-interface 
+  (export read-crlf-line
+	  read-crlf-line-timeout
+	  write-crlf))
+
+(define-interface ls-interface 
+  (export ls-crlf?
+	  ls
+	  arguments->ls-flags))
+
+(define-interface format-net-interface
+  (export format-internet-host-address
+	  format-port))
+
+(define-interface sunet-utilities-interface
+  (export host-name-or-ip
+	  on-interrupt
+	  socket-address->string
+	  dump
+	  system-fqdn
+	  copy-inport->outport
+	  dotdot-check))
+
+(define-interface handle-fatal-error-interface
+  (export with-fatal-error-handler*
+	  (with-fatal-error-handler :syntax)))
+
+;; FTP server
+
+(define-interface ftpd-interface 
+  (export ftpd
+	  ftpd-inetd))
+
+;; Web server
+
+(define-interface httpd-core-interface
+  (export httpd))
+
+(define-interface httpd-make-options-interface
+  (export make-httpd-options
+	  with-port
+	  with-root-directory
+	  with-icon-name
+	  with-fqdn
+	  with-reported-port
+	  with-path-handler
+	  with-server-admin
+	  with-simultaneous-requests
+	  with-logfile
+	  with-syslog?
+	  with-resolve-ips?))
+
+(define-interface httpd-read-options-interface
+  (export httpd-options-port
+	  httpd-options-root-directory
+	  httpd-options-icon-name
+	  httpd-options-fqdn
+	  httpd-options-reported-port
+	  httpd-options-path-handler
+	  httpd-options-server-admin
+	  httpd-options-simultaneous-requests
+	  httpd-options-logfile
+	  httpd-options-syslog?
+	  httpd-options-resolve-ips?))
+
+(define-interface httpd-access-control-interface
+  (export access-denier
+	  access-allower
+	  access-controller
+	  access-controlled-handler))
+
+(define-interface httpd-error-interface
+  (export http-error?
+	  http-error
+	  fatal-syntax-error?
+	  fatal-syntax-error))
+
+(define-interface httpd-logging-interface
+  (export init-http-log!
+	  http-syslog?
+	  http-syslog
+	  http-log
+	  logging
+	  make-logging))
+
+(define-interface httpd-request-interface
+  (export make-request 	; HTTP request
+	  request? 		; record type.
+	  request:method
+	  request:uri
+	  request:url
+	  request:version
+	  request:headers
+	  request:socket
+	  set-request:method
+	  set-request:uri
+	  set-request:url
+	  set-request:version
+	  set-request:headers
+	  set-request:socket
+
+	  version< version<=
+	  v0.9-request?
+	  version->string))
+
+(define-interface httpd-responses-interface
+  (export make-response response?
+	  response-code
+	  response-message
+	  response-seconds
+	  response-mime
+	  response-extras
+	  response-body
+
+	  make-writer-body writer-body?
+	  make-reader-writer-body reader-writer-body?
+	  make-redirect-body redirect-body? redirect-body-location
+	  display-http-body
+
+	  ;; Integer reply codes
+	  status-code->text
+	  http-status/ok
+	  http-status/created
+	  http-status/accepted
+	  http-status/prov-info
+	  http-status/no-content
+	  http-status/mult-choice
+	  http-status/moved-perm
+	  http-status/moved-temp
+	  http-status/method
+	  http-status/not-mod
+	  http-status/bad-request
+	  http-status/unauthorized
+	  http-status/payment-req
+	  http-status/forbidden
+	  http-status/not-found
+	  http-status/method-not-allowed
+	  http-status/none-acceptable
+	  http-status/proxy-auth-required
+	  http-status/timeout
+	  http-status/conflict
+	  http-status/gone
+	  http-status/internal-error
+	  http-status/not-implemented
+	  http-status/bad-gateway
+	  http-status/service-unavailable
+	  http-status/gateway-timeout
+	  http-status/redirect		; used internally
+
+	  make-http-error-response
+	  make-redirect-response
+	  time->http-date-string))
+
+(define-interface httpd-basic-handlers-interface
+  (export make-request-handler
+	  make-path-handler
+	  make-host-name-handler
+	  make-path-prefix-handler
+	  alist-path-dispatcher
+	  null-path-handler))
+
+(define-interface httpd-file-directory-handlers-interface
+  (export home-dir-handler
+	  tilde-home-dir-handler
+	  rooted-file-handler
+	  rooted-file-or-directory-handler))
+
+(define-interface seval-handler-interface
+  (export seval-handler))
+
+(define-interface info-gateway-interface
+  (export info-handler
+	  find-info-file
+	  info-gateway-error))
+
+(define-interface rman-gateway-interface
+(export rman-handler
+	man
+	parse-man-entry
+	cat-man-page
+	find-man-file
+	file->man-directory
+	cat-n-decode
+	nroff-n-decode))
+
+(define-interface cgi-server-interface 
+  (export cgi-default-bin-path
+	  cgi-handler))
+
+(define-interface loser-interface (export loser))
+
+(define-interface toothless-interface (interface-of scheme))
+
+(define-interface toothless-eval-interface (export eval-safely))
+
+;; Structures
+
+(define-structure sunet-version (export sunet-version-identifier)
+  (open scheme)
+  (begin
+    (define sunet-version-identifier "2.0")))
+
+;; Net protocols and formats
+
+(define-structure parse-html-forms parse-html-forms-interface
+  (open scsh 
+	scsh-utilities 
+	let-opt 
+	srfi-13
+	receiving 
+	uri
+	scheme)
+  (files (lib parse-forms)))
+
+(define-structure htmlout htmlout-interface
+  (open scsh scsh-utilities srfi-13 formats ascii receiving scheme)
+  (files (lib htmlout)))
+
+(define-structure smtp smtp-interface
+				
+  (open scsh				; write-string read-string/partial force-output
+					; user-login-name and sockets
+	(subset srfi-1 (filter-map))
+	crlf-io				; read-crlf-line write-crlf
+	receiving			; values receive
+	let-opt				; let-optionals
+	error-package			; error
+	dns				; SYSTEM-FQDN
+	scheme)
+  (files (lib smtp)))
+
+(define-structure rfc822 rfc822-interface
+  (open receiving	; MV return (RECEIVE and VALUES)
+	scsh-utilities	; index
+	srfi-13
+	srfi-1		; fold
+	let-opt         ; let-optionals
+	crlf-io		; read-crlf-line
+	ascii		; ascii->char
+	error-package	; error
+	scsh		; string-join
+	scheme)
+  (files (lib rfc822)))
+
+(define-structure uri uri-interface
+  (open scsh-utilities
+	srfi-13
+	let-opt
+	receiving
+	ascii
+	srfi-14
+	bitwise
+	field-reader-package
+	scheme)
+  (files (lib uri)))
+
+(define-structure url url-interface
+  (open defrec-package
+	receiving
+	srfi-13
+	srfi-14
+	uri
+	scsh-utilities
+	httpd-error
+	scheme)
+  (files (lib url)))
+
+(define-structure ftp ftp-interface
+  (open netrc
+        scsh
+        defrec-package
+        receiving
+        handle
+        conditions
+        signals
+        error-package
+	srfi-13
+	let-opt
+	sunet-utilities
+	crlf-io
+        scheme)
+  (files (lib ftp)))
+
+(define-structure ftp-obsolete ftp-obsolete-interface
+  (open scsh
+	scheme
+	ftp)
+  (begin
+    (define ftp:connect ftp-connect)
+    (define ftp:login ftp-login)
+    (define ftp:type ftp-type)
+    (define ftp:rename ftp-rename)
+    (define ftp:delete ftp-delete)
+    (define ftp:cd ftp-cd)
+    (define ftp:cdup ftp-cdup)
+    (define ftp:pwd ftp-pwd)
+    (define ftp:rmdir ftp-rmdir)
+    (define ftp:mkdir ftp-mkdir)
+    (define ftp:modification-time ftp-modification-time)
+    (define ftp:size ftp-size)
+    (define ftp:abort ftp-abort)
+    (define ftp:quit ftp-quit)
+    (define ftp:ls ftp-ls)
+    (define ftp:dir ftp-dir)
+    (define ftp:get ftp-get)
+    (define ftp:put ftp-put)
+    (define ftp:append ftp-append)
+    (define ftp:quot ftp-quot)))
+
+
+
+(define-structure netrc netrc-interface
+  (open defrec-package
+	records
+        scsh        
+        error-package
+	srfi-13
+	conditions signals handle
+	sunet-utilities
+	let-opt
+        scheme)
+  (files (lib netrc)))
+
+(define-structure pop3 pop3-interface
+  (open netrc
+        scsh
+        defrec-package
+        handle
+        conditions
+        signals
+	srfi-13
+	let-opt
+	crlf-io
+        scheme)
+  (files (lib pop3)))
+
+(define-structure pop3-obsolete pop3-obsolete-interface
+  (open scsh
+	scheme
+	pop3)
+  (begin
+    (define pop3:connect pop3-connect)
+    (define pop3:login pop3-login)
+    (define pop3:stat pop3-stat)
+    (define pop3:get pop3-get)
+    (define pop3:headers pop3-headers)
+    (define pop3:last pop3-last)
+    (define pop3:delete pop3-delete)
+    (define pop3:reset pop3-reset)
+    (define pop3:quit pop3-quit)))
+
+(define-structure nettime nettime-interface
+  (open scsh
+        scheme)
+  (files (lib nettime)))
+
+(define-structure nettime-obsolete nettime-obsolete-interface
+  (open scsh
+	scheme
+	nettime)
+  (begin
+    (define net:time net-time)
+    (define net:daytime net-daytime)))
+
+(define-structure dns dns-interface
+  (open scheme
+	scsh
+	big-util
+	tables
+	ascii
+	formats
+	signals
+	defrec-package
+	random
+	queues
+	conditions
+	handle
+	sort
+	threads
+	locks)
+  (files (lib dns)))
+
+(define-structure cgi-script cgi-script-interface
+  (open scsh
+	error-package
+	parse-html-forms
+	scheme)
+  (files (lib cgi-script)))
+
+;; Utility libraries
+
+(define-structure rate-limit rate-limit-interface
+  (open scheme
+	define-record-types
+	locks
+	signals)
+  (files (lib rate-limit)))
+
+(define-structure crlf-io crlf-io-interface
+  (open ascii		; ascii->char
+	scsh		; read-line write-string force-output
+	receiving	; MV return (RECEIVE and VALUES)
+	let-opt		; let-optionals
+	threads         ; sleep
+	scheme)	
+  (files (lib crlf-io)))
+
+(define-structure ls ls-interface
+  (open scheme handle
+	big-scheme bitwise
+	fluids
+	crlf-io
+	scsh)
+  (files (lib ls)))
+
+(define-structure format-net format-net-interface
+  (open scsh
+	scheme
+	let-opt)    ; :optional
+  (files (lib format-net)))
+
+(define-structure sunet-utilities sunet-utilities-interface
+  (open scsh
+	scheme
+	format-net
+	sigevents
+	let-opt
+	srfi-13
+	dns
+	let-opt				; :optional
+	handle-fatal-error)
+  (files (lib sunet-utilities)))
+
+(define-structure handle-fatal-error handle-fatal-error-interface
+  (open scheme conditions handle)
+  (files (httpd handle-fatal-error)))
+
+;; FTP server
+
+(define-structure ftpd ftpd-interface 
+  (open scheme (modify scsh (hide char-set:whitespace))
+	conditions handle signals
+	structure-refs
+	handle-fatal-error
+	threads threads-internal    ; last one to get CURRENT-THREAD
+	locks
+	thread-fluids               ; fork-thread
+	fluids
+	srfi-14
+	srfi-13
+	big-util
+	defrec-package
+	crlf-io
+	ls
+	dns
+	sunet-utilities
+	let-opt
+	receiving                   ; RECEIVE
+	format-net)                 ; pretty print of internet-addresses
+  (access big-scheme)
+  (files (ftpd ftpd)))
+
+;; Web server
+
+(define-structure httpd-core httpd-core-interface
+  (open thread-fluids			; fork-thread
+	scsh
+	receiving			; receive
+	crlf-io				; write-crlf, read-crlf-line
+	rfc822				; read-rfc822-headers
+	srfi-14				; char-set-complement, char-set:whitespace 
+	handle				; ignore-errors
+	conditions			; condition-stuff
+	uri
+	url
+	formats				; format
+	format-net			; format-internet-host-address
+	rate-limit			; rate-limiting stuff
+	srfi-13				; STRING-INDEX
+	dns				; dns-lookup-ip
+	sunet-utilities                 ; socket-address->string 
+	locks				; make-lock et al.
+	fluids				; let-fluid
+	enumerated			; enum
+	architecture			; exception, os-error
+	
+
+	handle-fatal-error
+	httpd-read-options
+	httpd-error
+	httpd-logging
+	httpd-request
+	httpd-responses
+
+	sunet-version
+	scheme
+	srfi-1)				; find
+  (files (httpd core)))
+
+(define-structures ((httpd-make-options httpd-make-options-interface)
+		    (httpd-read-options httpd-read-options-interface))
+  (open scheme
+	define-record-types)
+  (files (httpd options)))
+
+(define-structure httpd-access-control httpd-access-control-interface
+  (open big-scheme
+	httpd-responses
+	httpd-request
+	httpd-error
+	srfi-13    ; STRING-MAP
+	scsh
+	scheme)
+  (files (httpd access-control)))
+
+(define-structure httpd-error httpd-error-interface
+  (open conditions signals handle scheme)
+  (files (httpd error)))
+
+(define-structure httpd-logging httpd-logging-interface
+  (open httpd-read-options
+	i/o				; make-null-output-port
+	locks				; make-lock obtain-lock release-lock
+	receiving			; receive
+	uri				; uri-path-list->path
+	url				; http-url:path
+	httpd-request			; request record
+	formats				; format
+	format-net			; format-internet-host-address
+	srfi-13				; string-join, string-trim
+	rfc822				; get-header
+	sunet-utilities			; on-interrupt
+	threads				; spawn
+	dns				; dns-lookup-ip
+	defrec-package			; define-record
+	thread-fluids			; make-preserved-fluid et al.
+	
+	scsh
+	scheme)
+  (files (httpd logging)))
+
+(define-structure httpd-request httpd-request-interface
+  (open define-record-types    ;; define-record-discloser
+	defrec-package         ;; define-record  
+	scheme)
+  (files (httpd request)))
+
+(define-structure httpd-responses httpd-responses-interface
+  (open scheme
+	(subset scsh (format-date write-string time date))
+	syslog
+	srfi-9
+	defenum-package
+	formats
+	httpd-request
+	httpd-logging
+	httpd-read-options)
+  (files (httpd response)))
+
+(define-structure httpd-basic-handlers httpd-basic-handlers-interface
+  (open scheme scsh
+	rfc822
+	httpd-request			; REQUEST record type, v0.9-request
+	srfi-1				; FOLD-RIGHT
+	srfi-13				; STRING-TRIM
+	httpd-responses
+	)
+  (files (httpd handlers)))
+
+(define-structure httpd-file-directory-handlers httpd-file-directory-handlers-interface
+  (open scheme scsh
+	httpd-core
+	httpd-request
+	httpd-responses
+	httpd-error
+	httpd-basic-handlers
+	httpd-read-options
+	url
+	htmlout
+	crlf-io
+	srfi-13 ; STRING-JOIN
+	sunet-utilities			; dotdot-check, copy-inport->outport
+	conditions
+	handle-fatal-error
+	)
+  (files (httpd file-dir-handler)))
+
+(define-structure seval-handler seval-handler-interface
+  (open scsh				; syscalls & INDEX
+	httpd-error
+	httpd-request			; v0.9-request
+	httpd-responses
+	httpd-logging			; http-log
+	uri				; UNESCAPE-URI
+	htmlout				; Formatted HTML output
+	error-package			; ERROR
+	pp				; Pretty-printer
+	srfi-13			; STRING-SKIP
+	rfc822
+	toothless-eval			; EVAL-SAFELY
+	handle				; IGNORE-ERROR
+	parse-html-forms		; PARSE-HTML-FORM-QUERY
+	threads				; SLEEP
+	scheme)
+  (files (httpd seval)))
+
+(define-structure info-gateway  info-gateway-interface
+  (open big-scheme
+	srfi-13
+	conditions signals handle
+	htmlout
+	httpd-request
+	httpd-responses
+	httpd-error
+	url
+	uri
+	scsh
+	handle-fatal-error
+	scheme)
+  (files (httpd info-gateway)))
+
+(define-structure rman-gateway rman-gateway-interface
+  (open httpd-responses
+	httpd-request
+	httpd-error
+	conditions
+	url
+	uri
+	htmlout
+	httpd-basic-handlers
+	handle-fatal-error
+	scsh
+	let-opt
+	sunet-utilities
+	srfi-13
+	scheme)
+  (files (httpd rman-gateway)))
+
+(define-structure cgi-server cgi-server-interface
+  (open	srfi-13
+	rfc822
+	crlf-io			; WRITE-CRLF
+	uri
+	url			; HTTP-URL record type
+	httpd-logging
+	httpd-request
+	httpd-responses
+	httpd-basic-handlers	; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
+	httpd-error		; HTTP-ERROR
+	httpd-file-directory-handlers		; dot-dot-check, copy-inport->outport
+	sunet-version
+	scsh-utilities		; INDEX
+	scsh			; syscalls
+	formats			; format
+	format-net              ; FORMAT-INTERNET-HOST-ADDRESS
+	sunet-utilities         ; host-name-or-empty
+	let-opt                 ; let-optionals
+	handle-fatal-error
+	scheme)
+  (files (httpd cgi-server)))
+
+(define-structure loser (export loser)
+  (open scheme error-package)
+  (begin (define (loser name)
+	   (lambda x (error "Illegal call" name)))))
+
+(define-structure toothless toothless-interface
+  (open scheme loser)
+  (begin
+    (define call-with-input-file	(loser "call-with-input-file"))
+    (define call-with-output-file	(loser "call-with-output-file"))
+    (define load			(loser "load"))
+    (define open-input-file		(loser "open-input-file"))
+    (define open-output-file		(loser "open-output-file"))
+    (define transcript-on		(loser "transcript-on"))
+    (define with-input-from-file	(loser "with-input-from-file"))
+    (define with-input-to-file		(loser "with-input-to-file"))
+    (define eval			(loser "eval"))
+    (define interaction-environment	(loser "interaction-environment"))
+    (define scheme-report-environment	(loser "scheme-report-environment"))))
+
+(define-structure toothless-eval toothless-eval-interface
+  (open evaluation			; eval
+	package-commands-internal	; config-package, get-reflective-tower
+	packages			; structure-package, make-simple-package
+	environments			; environment-ref
+	handle				; ignore-errors
+	scheme)
+  (access toothless)	; Force it to be loaded.
+  (begin
+
+    (define toothless-struct (environment-ref (config-package) 'toothless))
+    (define toothless-package (structure-package toothless-struct))
+
+    (define (new-safe-package)
+      (make-simple-package (list toothless-struct) #t
+			   (get-reflective-tower toothless-package) ; ???
+			   'safe-env))
+
+    (define (eval-safely exp)
+      (ignore-errors (lambda () (eval exp (new-safe-package)))))))

scheme/xml/doc.txt

@@ -0,0 +1,283 @@
+_XML_ Library
+=============
+
+Files: xml.ss xmlr.ss xmls.ss
+Signature: xml^
+
+Basic XML Data Types
+====================
+
+Document:
+       This structure represents an XML document.  The only useful part is
+       the document-element, which contains all the content.  The rest of
+       of the structure contains DTD information, which isn't supported,
+       and processing-instructions.
+
+Element:
+       Each pair of start/end tags and everything in between is an element.
+       It has the following pieces:
+              a name
+              attributes
+              contents including sub-elements
+Xexpr:
+       S-expression representations of XML data.
+
+The end of this document has more details.
+
+Functions
+=========
+
+> read-xml : [Input-port] -> Document
+       reads in an XML document from the given or current input port
+       XML documents contain exactly one element.  It throws an xml-read:error
+       if there isn't any element or if there are more than one element.
+       
+       Malformed xml is reported with source locations in
+       the form `l.c/o', where l is the line number, c is
+       the column number and o is the number of characters
+       from the beginning of the file.
+
+> write-xml : Document [Output-port] -> Void
+       writes a document to the given or current output port, currently
+       ignoring everything except the document's root element.
+
+> write-xml/content : Content [Output-port] -> Void
+       writes a document's contents to the given or current output port
+
+> display-xml : Document [Output-port] -> Void
+       just like write-xml, but newlines and indentation make the output more
+       readable, though less technically correct when white space is
+       significant.
+
+> display-xml/content : Content [Output-port] -> Void
+       just like write-xml/content, but with indentation and newlines
+
+> xml->xexpr : Content -> Xexpr
+       converts the interesting part of an XML document into an Xexpression
+
+> xexpr->xml : Xexpr -> Content
+       converts an Xexpression into the interesting part of an XML document
+
+> xexpr->string : Xexpression -> String
+       converts an Xexpression into a string representation
+       
+> eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
+       Some elements should not contain any text, only other tags, except they
+       often contain whitespace for formating purposes.  Given a list of tag names
+       and the identity function, eliminate-whitespace produces a function that
+       filters out pcdata consisting solely of whitespace from those elements and
+       raises and error if any non-whitespace text appears.  Passing in the function
+       called "not" instead of the identity function filters all elements which are not
+       named in the list.  Using void filters all elements regardless of the list.
+
+Parameters
+==========
+
+> empty-tag-shorthand : 'always | 'never | (listof Symbol)
+       Default: 'always
+       This determines if the output functions should use the <empty/> tag
+       notation instead of writing <empty></empty>.  The first form is the
+       preferred XML notation.  However, most browsers designed for HTML
+       will only properly render XHTML if the document uses a mixture of the
+       two formats.  _html-empty-tags_ contains the W3 consortium's
+       recommended list of XHTML tags that should use the shorthand.
+
+> collapse-whitespace : Bool
+       Default: #f
+       All consecutive whitespace is replaced by a single space.
+       CDATA sections are not affected.
+
+> trim-whitespace : Bool
+       This parameter no longer exists.  Consider using collapse-whitespace
+       and eliminate-whitespace instead.
+
+> read-comments : Bool
+       Default: #f
+       Comments, by definition, should be ignored by programs.  However,
+       interoperating with ad hoc extentions to other languages sometimes
+       requires processing comments anyway.
+
+> xexpr-drop-empty-attributes : Bool
+       Default: #f
+       It's easier to write functions processing Xexpressions, if they always
+       have a list of attributes.  On the other hand, it's less cumbersome to
+       write Xexpresssions by hand without empty lists of attributes
+       everywhere.  Normally xml->xexpr leaves in empty attribute lists.
+       Setting this parameter to #t drops them, so further editing the
+       Xexpression by hand is less annoying.
+
+Examples
+========
+
+Reading an Xexpression:
+       (xml->xexpr (document-element (read-xml input-port)))
+
+Writing an Xexpression:
+       (empty-tag-shorthand html-empty-tags)
+       (write-xml/content (xexpr->xml `(html (head (title ,banner))
+					     (body ((bgcolor "white"))
+						   ,text)))
+			  output-port)
+
+What this Library Doesn't Provide
+=================================
+
+       Document Type Declaration (DTD) processing
+       Validation
+       Expanding user-defined entites
+       Reading user-defined entites in attributes
+       Unicode support
+
+XML Datatype Details
+====================
+
+Note: Users of the XML collection don't need to know most of these definitions.
+
+Note: Xexpr is the only important one to understand.  Even then,
+      Processing-instructions may be ignored.
+
+> Xexpr = String
+        |  (list* Symbol (listof (list Symbol String)) (list Xexpr))
+        |  (cons Symbol (listof Xexpr)) ;; an element with no attributes
+        |  Symbol ;; symbolic entities such as &nbsp;
+        |  Number ;; numeric entities like &#20;
+        |  Misc
+
+> Document = (make-document Prolog Element (listof Processing-instruction))
+  (define-struct document (prolog element misc))
+
+> Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
+  (define-struct prolog (misc dtd misc2))
+  The last field is a (listof Misc), but the maker accepts optional
+  arguments instead for backwards compatibility.
+
+> Document-type = #f | (make-document-type Symbol External-dtd #f)
+  (define-struct document-type (name external inlined))
+
+> External-dtd = (make-external-dtd/public str str)
+               | (make-external-dtd/system str)
+               | #f
+  (define-struct external-dtd (system))
+  (define-struct (external-dtd/public external-dtd) (public))
+  (define-struct (external-dtd/system external-dtd) ())
+
+> Element = (make-element Location Location
+			    Symbol
+			    (listof Attribute)
+			    (listof Content))
+  (define-struct (element struct:source) (name attributes content))
+
+> Attribute = (make-attribute Location Location Symbol String)
+  (define-struct (attribute struct:source) (name value))
+
+> Content = Pcdata
+          |  Element
+          |  Entity
+          |  Misc
+
+  Misc = Comment
+       |  Processing-instruction
+
+> Pcdata = (make-pcdata Location Location String)
+  (define-struct (pcdata struct:source) (string))
+
+> Entity = (make-entity (U Nat Symbol))
+  (define-struct entity (text))
+
+> Processing-instruction = (make-pi Location Location String (list String))
+  (define-struct (pi struct:source) (target-name instruction))
+
+> Comment = (make-comment String)
+  (define-struct comment (text))
+
+  Source = (make-source Location Location)
+  (define-struct source (start stop))
+
+  Location = Nat
+           |  Symbol
+
+
+The PList Library
+=================
+
+Files: plist.ss
+
+The PList library provides the ability to read and write xml documents which 
+conform to the "plist" DTD, used to store 'dictionaries' of string - value
+associations.
+
+To Load
+=======
+
+(require (lib "plist.ss" "xml"))
+
+Functions
+=========
+
+> read-plist : Port -> PLDict
+       reads a plist from a port, and produces a 'dict' x-expression  
+
+> write-plist : PLDict Port -> Void
+       writes a plist to the given port.  May raise the exn:application:type
+       exception if the plist is badly formed.
+
+Datatypes
+=========
+
+NB: all of these are subtypes of x-expression:
+
+> PLDict = (list 'dict Assoc-pair ...)
+
+> PLAssoc-pair = (list 'assoc-pair String PLValue)
+
+> PLValue = String
+	  
+          | (list 'true)
+          | (list 'false)
+          | (list 'integer Integer)
+          | (list 'real Real)
+          | PLDict
+          | PLArray
+
+> PLArray = (list 'array PLValue ...)
+
+In fact, the PList DTD also defines Data and Date types, but we're ignoring
+these for the moment.
+
+Examples
+========
+
+Here's a sample PLDict:
+
+(define my-dict
+     `(dict (assoc-pair "first-key"
+			"just a string
+                         with some whitespace in it")
+	    (assoc-pair "second-key"
+			(false))
+	    (assoc-pair "third-key"
+			(dict ))
+	    (assoc-pair "fourth-key"
+			(dict (assoc-pair "inner-key"
+					  (real 3.432))))
+	    (assoc-pair "fifth-key"
+			(array (integer 14)
+			       "another string"
+			       (true)))
+	    (assoc-pair "sixth-key"
+			(array))))
+
+Let's write it to disk:
+
+   (call-with-output-file "/Users/clements/tmp.plist"
+     (lambda (port)
+       (write-plist my-dict port))
+     'truncate)
+
+Let's read it back from the disk:
+
+   (define new-dict
+     (call-with-input-file "/Users/clements/tmp.plist"
+       (lambda (port)
+	 (read-plist port))))
+

scheme/xml/plt.scm

@@ -0,0 +1,153 @@
+; Taken directly from the SRFI document.
+
+(define-syntax let-values
+  (syntax-rules ()
+    ((let-values (?binding ...) ?body0 ?body1 ...)
+     (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
+    
+    ((let-values "bind" () ?tmps ?body)
+     (let ?tmps ?body))
+    
+    ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
+     (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
+    
+    ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
+     (call-with-values 
+       (lambda () ?e0)
+       (lambda ?args
+         (let-values "bind" ?bindings ?tmps ?body))))
+    
+    ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
+     (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
+    
+    ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
+     (call-with-values
+       (lambda () ?e0)
+       (lambda (?arg ... . x)
+         (let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
+
+(define-syntax let*-values
+  (syntax-rules ()
+    ((let*-values () ?body0 ?body1 ...)
+     (begin ?body0 ?body1 ...))
+
+    ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
+     (let-values (?binding0)
+       (let*-values (?binding1 ...) ?body0 ?body1 ...)))))
+
+(define (add1 x) (+ x 1))
+(define (sub1 x) (- x 1))
+
+(define-syntax when
+  (syntax-rules 
+   ()
+   ((when test expr ...)
+    (if test (begin expr ...)))))
+
+(define-syntax unless
+  (syntax-rules
+   ()
+   ((unless test expr ...)
+    (if (not test) (begin expr ...)))))
+
+(define (void . a) 
+  (if #f #f))
+
+(define-syntax begin0
+  (syntax-rules
+   ()
+   ((begin0 expr1 expr ...)
+    (let ((r expr1))
+      (begin expr ...)
+      r))))
+
+(define andmap
+  (lambda (f list0 . lists)
+    (if (null? list0)
+	(and)
+	(let loop ((lists (cons list0 lists)))
+	  (if (null? (cdr (car lists)))
+	      (apply f (map car lists))
+	      (and (apply f (map car lists))
+		   (loop (map cdr lists))))))))
+(define null '())
+
+; stolen from mzlib/functior.ss
+(define (quicksort l less-than)
+  (let* ((v (list->vector l))
+	 (count (vector-length v)))
+    (let loop ((min 0)(max count))
+      (if (< min (sub1 max))
+	  (let ((pval (vector-ref v min)))
+	    (let pivot-loop ((pivot min)
+			     (pos (add1 min)))
+	      (if (< pos max)
+		  (let ((cval (vector-ref v pos)))
+		    (if (less-than cval pval)
+			(begin
+			  (vector-set! v pos (vector-ref v pivot))
+                               (vector-set! v pivot cval)
+                               (pivot-loop (add1 pivot) (add1 pos)))
+			(pivot-loop pivot (add1 pos))))
+		  (if (= min pivot)
+		      (loop (add1 pivot) max)
+		      (begin
+			(loop min pivot)
+			(loop pivot max))))))))
+    (vector->list v)))
+
+;;; HACK!
+(define call/ec call-with-current-continuation)
+(define-syntax let/ec
+  (syntax-rules
+   ()
+   ((let/ec k expr ...)
+    (call-with-current-continuation (lambda (k) expr ...)))))
+
+
+;;; HACK!
+(define (make-parameter val . maybe-guard)
+  (if (null? maybe-guard)
+      (lambda ()
+	val)
+      (lambda ()
+	((car maybe-guard) val))))
+
+(define (list* . args)
+  (if (null? (cdr args))
+      (car args)
+      (cons (car args) (apply list* (cdr args)))))
+
+(define (format str . args)
+  (apply (structure-ref big-scheme format) #f str args))
+
+(define fprintf (structure-ref big-scheme format))
+
+(define foldr (structure-ref list-lib fold-right))
+
+(define regexp posix-string->regexp)
+
+;;; convert "\\1y \\2" to '(1 "y " 2)
+(define (convert-string str)
+  (let ((e.s 
+	 (regexp-fold (rx (: "\\" numeric)) 
+		      (lambda (s m nil) 
+			(cons (match:end m) 
+			      (append (cdr nil)
+				      (list (substring str (car nil) (match:start m))
+					    (string->number 
+					     (string-drop (match:substring m) 2))))))
+		      (cons 0 '())  str)))
+    (append (cdr e.s) (list (substring str (car e.s) (string-length str))))))
+
+;;; does not handle &
+(define (regexp-replace* pattern string insert-string)
+  (apply regexp-substitute/global #f pattern string 
+	 (append (cons 'pre (convert-string insert-string)) (list 'post))))
+
+(define (compose f g)
+  (lambda (x) 
+    (call-with-values (lambda () (g x)) f)))
+
+(define open-output-string make-string-output-port)
+(define get-output-string string-output-port-output)

scheme/xml/reader.scm

@@ -0,0 +1,378 @@
+;; Token ::= Contents | Start-tag | End-tag | Eof
+
+(define read-comments (make-parameter #f))
+(define collapse-whitespace (make-parameter #f))
+
+;; read-xml : [Input-port] -> Document
+(define (read-xml . maybe-port)
+  (read-from-port (if (null? maybe-port) (current-input-port) (car maybe-port))))
+
+
+;; read-from-port : Input-port -> Document
+(define (read-from-port in)
+  (let*-values (((in pos) (positionify in))
+                ((misc0 start) (read-misc in pos)))
+    (make-document (make-prolog misc0 #f)
+                   (cond
+                     ((start-tag? start) (read-element start in pos))
+                     ((element? start) start)
+                     (else (error 'read-xml "expected root element - received ~a" start)))
+                   (let-values (((misc1 end-of-file) (read-misc in pos)))
+                     (unless (eof-object? end-of-file)
+                       (error 'read-xml "extra stuff at end of document ~a" end-of-file))
+                     misc1))))
+
+;; read-misc : Input-port (-> Location) -> (listof Misc) Token
+(define (read-misc in pos)
+  (let read-more ()
+    (let ((x (lex in pos)))
+      (cond
+        ((or (pi? x) (comment? x))
+         (let-values (((lst next) (read-more)))
+           (values (cons x lst) next)))
+        ((and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x))))
+         (read-more))
+        (else (values null x))))))
+
+;; read-element : Start-tag Input-port (-> Location) -> Element
+(define (read-element start in pos)
+  (let ((name (start-tag-name start))
+        (a (source-start start))
+        (b (source-stop start)))
+    (make-element
+     a b name (start-tag-attrs start)
+     (let read-content ()
+       (let ((x (lex in pos)))
+         (cond
+           ((eof-object? x)
+            (error 'read-xml "unclosed ~a tag at [~a ~a]" name 
+		   (format-source a)
+		   (format-source b)))
+           ((start-tag? x) (cons (read-element x in pos) (read-content)))
+           ((end-tag? x)
+            (unless (eq? name (end-tag-name x))
+              (error 'read-xml "start tag ~a at [~a ~a] doesn't match end tag ~a at [~a ~a]"
+		     name
+		     (format-source a)
+		     (format-source b)
+		     (end-tag-name x)
+		     (format-source (source-start x))
+		     (format-source (source-stop x))))
+            null)
+           ((entity? x) (cons (expand-entity x) (read-content)))
+           ((comment? x) (if (read-comments)
+                             (cons x (read-content))
+                             (read-content)))
+           (else (cons x (read-content)))))))))
+
+;; expand-entity : Entity -> (U Entity Pcdata)
+;; more here - allow expansion of user defined entities
+(define (expand-entity x)
+  (let ((expanded (default-entity-table (entity-text x))))
+    (if expanded
+        (make-pcdata (source-start x) (source-stop x) expanded)
+        x)))
+
+;; default-entity-table : Symbol -> (U #f String)
+(define (default-entity-table name)
+  (case name
+    ((amp) "&")
+    ((lt) "<")
+    ((gt) ">")
+    ((quot) "\"")
+    ((apos) "'")
+    (else #f)))
+
+;; lex : Input-port (-> Location) -> Token
+(define (lex in pos)
+  (let ((c (peek-char in)))
+    (cond
+      ((eof-object? c) c)
+      ((eq? c #\&) (lex-entity in pos))
+      ((eq? c #\<) (lex-tag-cdata-pi-comment in pos))
+      (else (lex-pcdata in pos)))))
+
+;; lex-entity : Input-port (-> Location) -> Entity
+(define (lex-entity in pos)
+  (let ((start (pos)))
+    (read-char in)
+    (let ((data (case (peek-char in)
+                  ((#\#)
+                   (read-char in)
+                   (let ((n (case (peek-char in)
+                              ((#\x) (read-char in)
+                               (string->number (read-until #\; in pos) 16))
+                              (else (string->number (read-until #\; in pos))))))
+                     (unless (number? n)
+                       (lex-error in pos "malformed numeric entity"))
+                     n))
+                  (else
+                   (begin0
+                     (lex-name in pos)
+                     (unless (eq? (read-char in) #\;)
+                       (lex-error in pos "expected ; at the end of an entity")))))))
+      (make-entity start (pos) data))))
+
+;; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
+(define (lex-tag-cdata-pi-comment in pos)
+  (let ((start (pos)))
+    (read-char in)
+    (case (non-eof peek-char in pos)
+      ((#\!)
+       (read-char in)
+       (case (non-eof peek-char in pos)
+         ((#\-) (read-char in)
+          (unless (eq? (read-char in) #\-)
+            (lex-error in pos "expected second - after <!-"))
+          (let ((data (lex-comment-contents in pos)))
+            (unless (eq? (read-char in) #\>)
+              (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)"))
+            ;(make-comment start (pos) data)
+            (make-comment data)))
+         ((#\[) (read-char in)
+          (unless (string=? (read-string 6 in) "CDATA[")
+            (lex-error in pos "expected CDATA following <["))
+          (let ((data (lex-cdata-contents in pos)))
+            (make-pcdata start (pos) data)))
+         (else (skip-dtd in pos)
+               (skip-space in)
+               (unless (eq? (peek-char in) #\<)
+                 (lex-error in pos "expected pi, comment, or element after doctype"))
+               (lex-tag-cdata-pi-comment in pos))))
+      ((#\?) (read-char in)
+       (let ((name (lex-name in pos)))
+         (skip-space in)
+         (let ((data (lex-pi-data in pos)))
+           (make-pi start (pos) name data))))
+      ((#\/) (read-char in)
+       (let ((name (lex-name in pos)))
+         (skip-space in)
+         (unless (eq? (read-char in) #\>)
+           (lex-error in pos "expected > to close ~a's end tag" name))
+         (make-end-tag start (pos) name)))
+      (else
+       (let ((name (lex-name in pos))
+             (attrs (lex-attributes in pos)))
+         (skip-space in)
+         (case (read-char in)
+           ((#\/)
+            (unless (eq? (read-char in) #\>)
+              (lex-error in pos "expected > to close empty element ~a" name))
+            (make-element start (pos) name attrs null))
+           ((#\>) (make-start-tag start (pos) name attrs))
+           (else (lex-error in pos "expected / or > to close tag `~a'" name))))))))
+
+;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
+(define (lex-attributes in pos)
+  (quicksort (let loop ()
+               (skip-space in)
+               (cond
+                 ((name-start? (peek-char in))
+                  (cons (lex-attribute in pos) (loop)))
+                 (else null)))
+             (lambda (a b)
+               (let ((na (attribute-name a))
+                     (nb (attribute-name b)))
+                 (cond
+                   ((eq? na nb) (lex-error in pos "duplicated attribute name ~a" na))
+                   (else (string<? (symbol->string na) (symbol->string nb))))))))
+
+;; lex-attribute : Input-port (-> Location) -> Attribute
+(define (lex-attribute in pos)
+  (let ((start (pos))
+        (name (lex-name in pos)))
+    (skip-space in)
+    (unless (eq? (read-char in) #\=)
+      (lex-error in pos "expected = in attribute ~a" name))
+    (skip-space in)
+    ;; more here - handle entites and disallow "<"
+    (let* ((delimiter (read-char in))
+           (value (case delimiter
+                    ((#\' #\")
+                     (list->string
+                      (let read-more ()
+                        (let ((c (non-eof peek-char in pos)))
+                          (cond
+                            ((eq? c delimiter) (read-char in) null)
+                            ((eq? c #\&)
+                             (let ((entity (expand-entity (lex-entity in pos))))
+                               (if (pcdata? entity)
+                                   (append (string->list (pcdata-string entity)) (read-more))
+                                   ;; more here - do something with user defined entites
+                                   (read-more))))
+                            (else (read-char in) (cons c (read-more))))))))
+                    (else (lex-error in pos "attribute values must be in ''s or in \"\"s")))))
+      (make-attribute start (pos) name value))))
+
+;; skip-space : Input-port -> Void
+;; deviation - should sometimes insist on at least one space
+(define (skip-space in)
+  (let loop ()
+    (let ((c (peek-char in)))
+      (when (and (not (eof-object? c)) (char-whitespace? c))
+        (read-char in)
+        (loop)))))
+
+;; lex-pcdata : Input-port (-> Location) -> Pcdata
+;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec 
+(define (lex-pcdata in pos)
+  (let ((start (pos))
+        (data (let loop ()
+                (let ((next (peek-char in)))
+                  (cond
+                    ((or (eof-object? next) (eq? next #\&) (eq? next #\<))
+                     null)
+                    ((and (char-whitespace? next) (collapse-whitespace))
+                     (skip-space in)
+                     (cons #\space (loop)))
+                    (else (cons (read-char in) (loop))))))))
+    (make-pcdata start
+                 (pos)
+                 (list->string data))))
+
+;; lex-name : Input-port (-> Location) -> Symbol
+(define (lex-name in pos)
+  (let ((c (read-char in)))
+    (unless (name-start? c)
+      (lex-error in pos "expected name, received ~a" c))
+    (string->symbol
+     (list->string
+      (cons c (let lex-rest ()
+                (cond
+                  ((name-char? (peek-char in))
+                   (cons (read-char in) (lex-rest)))
+                  (else null))))))))
+
+;; skip-dtd : Input-port (-> Location) -> Void
+(define (skip-dtd in pos)
+  (let skip ()
+    (case (non-eof read-char in pos)
+      ((#\') (read-until #\' in pos) (skip))
+      ((#\") (read-until #\" in pos) (skip))
+      ((#\<)
+       (case (non-eof read-char in pos)
+         ((#\!) (case (non-eof read-char in pos)
+                  ((#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip))
+                  (else (skip) (skip))))
+         ((#\?) (lex-pi-data in pos) (skip))
+         (else (skip) (skip))))
+      ((#\>) (void))
+      (else (skip)))))
+
+;; name-start? : Char -> Bool
+(define (name-start? ch)
+  (or (char-alphabetic? ch) 
+      (eq? ch #\_)
+      (eq? ch #\:)))
+
+;; name-char? : Char -> Bool
+(define (name-char? ch)
+  (or (name-start? ch)
+      (char-numeric? ch)
+      (eq? ch #\.)
+      (eq? ch #\-)))
+
+;; read-until : Char Input-port (-> Location) -> String
+;; discards the stop character, too
+(define (read-until char in pos)
+  (list->string
+   (let read-more ()
+     (let ((c (non-eof read-char in pos)))
+       (cond
+         ((eq? c char) null)
+         (else (cons c (read-more))))))))
+
+;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
+(define (non-eof f in pos)
+  (let ((c (f in)))
+    (cond
+      ((eof-object? c) (lex-error in pos "unexpected eof"))
+      (else c))))
+
+;; gen-read-until-string : String -> Input-port (-> Location) -> String
+;; uses Knuth-Morris-Pratt from
+;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
+;; discards stop from input
+(define (gen-read-until-string stop)
+  (let* ((len (string-length stop))
+         (prefix (make-vector len 0))
+         (fall-back
+          (lambda (k c)
+            (let ((k (let loop ((k k))
+                       (cond
+                         ((and (> k 0) (not (eq? (string-ref stop k) c)))
+                          (loop (vector-ref prefix (sub1 k))))
+                         (else k)))))
+              (if (eq? (string-ref stop k) c)
+                  (add1 k)
+                  k)))))
+    (let init ((k 0) (q 1))
+      (when (< q len)
+        (let ((k (fall-back k (string-ref stop q))))
+          (vector-set! prefix q k)
+          (init k (add1 q)))))
+    ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
+    (lambda (in pos)
+      (list->string
+       (let/ec out
+         (let loop ((matched 0) (out out))
+           (let* ((c (non-eof read-char in pos))
+                  (matched (fall-back matched c)))
+             (cond
+               ((= matched len) (out null))
+               ((zero? matched) (cons c (let/ec out (loop matched out))))
+               (else (cons c (loop matched out)))))))))))
+
+;; "-->" makes more sense, but "--" follows the spec.
+(define lex-comment-contents (gen-read-until-string "--"))
+(define lex-pi-data (gen-read-until-string "?>"))
+(define lex-cdata-contents (gen-read-until-string "]]>"))
+
+;; positionify : Input-port -> Input-port (-> Location)
+
+;; Well, this really depends on scsh-0.6 and should be replace by
+;; big-scheme's more-port
+;; For S48 you probably need to do something completely different
+
+(define (positionify in)
+  (let ((line 1)
+	(char 0)
+	(offset 0)
+	(old-handler (port-handler in)))
+    (set-port-buffering in bufpol/block 1)
+    (let ((handler (make-buffered-input-port-handler
+		    (port-handler-discloser old-handler)
+		    (port-handler-close old-handler)
+		    (lambda (data buffer start needed)
+		      (let ((res 
+			     ((port-handler-buffer-proc old-handler) 
+			      data buffer start needed)))
+			(if (number? res)
+			    (begin
+			      (set! char (add1 char))
+			      (set! offset (add1 offset))
+			      (let ((c (byte-vector-ref buffer 0)))
+				(when (= c 10)
+				      (set! line (+ line 1))
+				      (set! char -1)))))
+			res))
+		    (port-handler-ready? old-handler)
+		    (port-handler-steal old-handler))))
+      (set-port-handler! in handler)
+      (values in
+	      (lambda ()
+		(make-location line char offset))))))
+;		(- n (- (port-limit in) (port-index in))))))))
+
+;; lex-error : Input-port String (-> Location) TST* -> alpha
+(define (lex-error in pos str . rest)
+  (error 'lex-error " at position:" (format-source (pos)) str rest))
+
+;; format-source : Location -> string
+;; to format the source location for an error message
+(define (format-source loc)
+  (if (location? loc)
+      (format #f "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
+      (format #f "~a" loc)))
+
+

scheme/xml/space.scm

@@ -0,0 +1,26 @@
+;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
+(define (eliminate-whitespace special eliminate-special?)
+  (letrec ((blank-it
+            (lambda (el)
+              (let ((name (element-name el))
+                    (content (map (lambda (x)
+                                    (if (element? x) (blank-it x) x))
+                                  (element-content el))))
+                (make-element
+                 (source-start el)
+                 (source-stop el)
+                 name
+                 (element-attributes el)
+                 (cond
+                   ((eliminate-special? (memq (element-name el) special))
+                    (filter (lambda (s)
+                              (not (and (pcdata? s)
+                                        (or (all-blank (pcdata-string s))
+                                            (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~s" name (pcdata-string s))))))
+                            content))
+                   (else content)))))))
+    blank-it))
+
+;; all-blank : String -> Bool
+(define (all-blank s) 
+  (andmap char-whitespace? (string->list s)))

scheme/xml/structures.scm

@@ -0,0 +1,194 @@
+; Location = (make-location Nat Nat) | Symbol
+(define-record-type location :location
+  (make-location line char offset)
+  location?
+  (line location-line)
+  (char location-char)
+  (offset location-offset))
+
+;; Source ::= (make-source Location Location)
+(define-record-type source :source
+  (make-source start stop)
+  really-source?
+  (start really-source-start)
+  (stop really-source-stop))
+ 
+(define (source-start obj)
+  (cond ((element? obj) (element-start obj))
+	((attribute? obj) (attribute-start obj))
+	((pcdata? obj) (pcdata-start obj))
+	((entity? obj) (entity-start obj))
+	((pi? obj) (pi-start obj))
+	((start-tag? obj) (start-tag-start obj))
+	((end-tag? obj) (end-tag-start obj))
+	(else (really-source-start obj))))
+
+(define (source-stop obj)
+  (cond ((element? obj) (element-stop obj))
+	((attribute? obj) (attribute-stop obj))
+	((pcdata? obj) (pcdata-stop obj))
+	((entity? obj) (entity-stop obj))
+	((pi? obj) (pi-stop obj))
+	((start-tag? obj) (start-tag-stop obj))
+	((end-tag? obj) (end-tag-stop obj))
+	(else (really-source-stop obj))))
+
+(define (does-any-satisfy? preds obj)
+    (if (null? preds)
+	#f
+	(or ((car preds) obj) (does-any-satisfy? (cdr preds) obj))))
+
+(define (source? obj)
+  (does-any-satisfy? (list really-source? element? attribute? pcdata? 
+			   entity? pi? start-tag? end-tag?)
+		     obj))
+
+;; Document ::= (make-document Prolog Element (listof Misc))
+(define-record-type document :document
+  (make-document prolog element misc)
+  document?
+  (prolog document-prolog)
+  (element document-element)
+  (misc document-misc))
+
+      ; Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
+      ; The Misc items after the Document-type are optional arguments to maintain
+      ; backward compatability with older versions of the XML library.
+      ;(define-struct prolog (misc dtd misc2))
+
+(define-record-type prolog :prolog
+  (really-make-prolog misc dtd misc2)
+  prolog?
+  (misc prolog-misc)
+  (dtd prolog-dtd)
+  (misc2 prolog-misc2))
+
+(define (make-prolog misc dtd . misc2)
+  (really-make-prolog misc dtd misc2))
+
+;;; Document-type = (make-document-type sym External-dtd #f)
+;;;               | #f
+
+(define-record-type document-type :document-type
+  (make-document-type name external inlined)
+  really-document-type?
+  (name document-type-name)
+  (external document-type-external)
+  (inlined document-type-inlined))
+
+;;; External-dtd = (make-external-dtd/public str str)
+;;;              | (make-external-dtd/system str)
+;;;              | #f
+(define-record-type external-dtd :external-dtd
+  (make-external-dtd system)
+  really-external-dtd?
+  (system really-external-dtd-system))
+
+(define (external-dtd-system external-dtd)
+  (cond ((really-external-dtd? external-dtd)
+	 (really-external-dtd-system external-dtd))
+	((external-dtd/public? external-dtd)
+	 (external-dtd/public-system external-dtd))
+	((external-dtd/system? external-dtd)
+	 (external-dtd/system-system external-dtd))
+	(else (error "bottom of external-dtd-system" external-dtd))))
+
+(define (external-dtd? obj)
+  (does-any-satisfy? (list really-external-dtd? external-dtd/public? 
+			   external-dtd/system?)
+		     obj))
+
+(define-record-type external-dtd/public :external-dtd/public
+  (make-external-dtd/public system public)
+  external-dtd/public?
+  (system external-dtd/public-system)
+  (public external-dtd/public-public))
+
+(define-record-type external-dtd/system :external-dtd/system
+  (make-external-dtd/system system)
+  external-dtd/system?
+  (system external-dtd/system-system))
+
+
+;; Element ::= (make-element Location Location Symbol (listof Attribute) (listof Content))
+(define-record-type element :element
+  (make-element start stop name attributes content)
+  element?
+  (start element-start)
+  (stop element-stop)
+  (name element-name)
+  (attributes element-attributes)
+  (content element-content))
+
+;; Attribute ::= (make-attribute Location Location Symbol String)
+(define-record-type attribute :attribute
+  (make-attribute start stop name value)
+  attribute?
+  (start attribute-start)
+  (stop attribute-stop)
+  (name attribute-name)
+  (value attribute-value))
+
+;; Pcdata ::= (make-pcdata Location Location String)
+(define-record-type pcdata :pcdata
+  (make-pcdata start stop string)
+  pcdata?
+  (start pcdata-start)
+  (stop pcdata-stop)
+  (string pcdata-string))
+
+;; Content ::= Pcdata  
+;;          |  Element
+;;          |  Entity
+;;          |  Misc
+
+;; Misc ::= Comment
+;;       |  Processing-instruction
+
+;; Entity ::= (make-entity Location Location (U Nat Symbol))
+(define-record-type entity :entity
+  (make-entity start stop text)
+  entity?
+  (start entity-start)
+  (stop entity-stop)
+  (text entity-text))
+
+;; Processing-instruction ::= (make-pi Location Location String (list String))
+;; also represents XMLDecl
+(define-record-type pi :pi
+  (make-pi start stop target-name instruction)
+  pi?
+  (start pi-start)
+  (stop pi-stop)
+  (target-name pi-target-name)
+  (instruction pi-instruction))
+
+;; Comment ::= (make-comment String)
+(define-record-type comment :comment
+  (make-comment text)
+  comment?
+  (text comment-text))
+
+;; content? : TST -> Bool
+(define (content? x)
+  (or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x)))
+
+
+;;; moved here from reader as it inherits from source
+;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
+(define-record-type start-tag :start-tag
+  (make-start-tag start stop name attrs)
+  start-tag?
+  (start start-tag-start)
+  (stop start-tag-stop)
+  (name start-tag-name)
+  (attrs start-tag-attrs))
+
+
+;; End-tag ::= (make-end-tag Location Location Symbol)
+(define-record-type end-tag :end-tag
+  (make-end-tag start stop name)
+  end-tag?
+  (start end-tag-start)
+  (stop end-tag-stop)
+  (name end-tag-name))

scheme/xml/writer.scm

@@ -0,0 +1,155 @@
+  
+;;(define empty-tag-shorthand (make-parameter #t))
+;;(define empty-tag-shorthand (make-parameter void))
+
+;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
+(define empty-tag-shorthand 
+  (make-parameter 'always 
+		  (lambda (x)
+		    (if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
+			x
+			(error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~a" x)))))
+
+(define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
+
+;; var-argify : (a Output-port -> b) -> (a [Output-port] -> b)
+(define (var-argify f)
+  (lambda (x . maybe-port)
+    (f x (if (null? maybe-port)
+	     (current-output-port)
+	     (car maybe-port)))))
+
+;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
+(define (gen-write/display-xml/content dent)
+  (var-argify (lambda (c out) 
+		(write-xml-content c 0 dent out))))
+
+;; indent : Nat Output-port -> Void
+(define (indent n out)
+  (newline out)
+  (let loop ((n n))
+    (unless (zero? n)
+      (display #\space out)
+      (loop (sub1 n)))))
+
+;; write-xml/content : Content [Output-port] -> Void
+(define write-xml/content (gen-write/display-xml/content void))
+
+;; display-xml/content : Content [Output-port] -> Void
+(define display-xml/content (gen-write/display-xml/content indent))
+
+;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
+(define (gen-write/display-xml output-content)
+  (var-argify (lambda (doc out)
+		(let ((prolog (document-prolog doc)))
+		  (display-outside-misc (prolog-misc prolog) out)
+		  (display-dtd (prolog-dtd prolog) out)
+		  (display-outside-misc (prolog-misc2 prolog) out))
+		(output-content (document-element doc) out)
+		(display-outside-misc (document-misc doc) out))))
+
+; display-dtd : document-type oport -> void
+(define (display-dtd dtd out)
+  (when dtd
+	(fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
+	(let ((external (document-type-external dtd)))
+	  (cond
+	   ((external-dtd/public? external)
+	    (fprintf out " PUBLIC \"~a\" \"~a\""
+		     (external-dtd/public-public external)
+		     (external-dtd-system external)))
+	   ((external-dtd/system? external)
+	    (fprintf out " SYSTEM \"~a\"" (external-dtd-system external)))
+	   ((not external) (void))))
+	(display ">" out)
+	(newline out)))
+
+;; write-xml : Document [Output-port] -> Void
+(define write-xml (gen-write/display-xml write-xml/content))
+
+;; display-xml : Document [Output-port] -> Void
+(define display-xml (gen-write/display-xml display-xml/content))
+
+;; display-outside-misc : (listof Misc) Output-port -> Void
+(define (display-outside-misc misc out)
+  (for-each (lambda (x)
+              ((cond
+                 ((comment? x) write-xml-comment)
+                 ((pi? x) write-xml-pi)
+		 (else (error "bottom " x))) x 0 void out)
+              (newline out))
+            misc))
+  
+;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+(define (write-xml-content el over dent out)
+  ((cond
+     ((element? el) write-xml-element)
+     ((pcdata? el) write-xml-pcdata)
+     ((entity? el) write-xml-entity)
+     ((comment? el) write-xml-comment)
+     ((pi? el) write-xml-pi)
+     (else (error 'write-xml-content "received ~a" el)))
+   el over dent out))
+
+;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+(define (write-xml-element el over dent out)
+  (let* ((name (element-name el))
+         (start (lambda (f) (write-xml-base (format f name) over dent out)))
+         (content (element-content el)))
+    (start "<~a")
+    (for-each (lambda (att)
+                (fprintf out " ~s=~s" (attribute-name att)
+                         (escape (attribute-value att) escape-attribute-table)))
+              (element-attributes el))
+    (if (and (null? content)
+             (let ((short (empty-tag-shorthand)))
+               (case short
+                 ((always) #t)
+                 ((never) #f)
+                 (else (memq name short)))))
+        (fprintf out " />")
+        (begin
+          (fprintf out ">")
+          (for-each (lambda (c) (write-xml-content c (incr over) dent out)) content)
+          (start "</~a")
+          (fprintf out ">")))))
+
+;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+(define (write-xml-base el over dent out)
+  (dent over out)
+  (display el out))
+
+;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+(define (write-xml-pcdata str over dent out)
+  (write-xml-base (escape (pcdata-string str) escape-table) over dent out))
+
+;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+(define (write-xml-pi pi over dent out)
+  (write-xml-base (format "<?~a ~a?>" (pi-target-name pi) (pi-instruction pi)) over dent out))
+
+;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
+(define (write-xml-comment comment over dent out)
+  (write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
+
+;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
+(define (write-xml-entity entity over dent out)
+  (let ((n (entity-text entity)))
+    (fprintf out (if (number? n) "&#~a;" "&~a;") n)))
+  
+(define escape-table
+  (map (lambda (x y) (cons (regexp (symbol->string x)) y))
+       '(< > &)
+       '("&lt;" "&gt;" "&amp;")))
+
+(define escape-attribute-table
+  (list* (cons (regexp "'") "&apos;") (cons (regexp "\"") "&quot;") escape-table))
+
+;; escape : String -> String
+;; more here - this could be much more efficient
+(define (escape x table)
+  (foldr (lambda (esc str) (regexp-replace* (car esc) str (cdr esc)))
+         x
+         table))
+
+;; incr : Nat -> Nat
+(define (incr n) (+ n 2))

scheme/xml/xexpr.scm

@@ -0,0 +1,81 @@
+;  (import xml-structs^ writer^ mzlib:function^)
+;; Xexpr ::= String
+;;        |  (list* Symbol (listof Attribute-srep) (listof Xexpr))
+;;        |  (cons Symbol (listof Xexpr))
+;;        |  Symbol
+;;        |  Nat
+;;        |  Comment
+;;        |  Processing-instruction
+;; Attribute-srep ::= (list Symbol String)
+
+;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
+
+;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
+(define (assoc-sort to-sort)
+  (quicksort to-sort (bcompose string<? (compose symbol->string car))))
+
+(define xexpr-drop-empty-attributes (make-parameter #f))
+
+;; xml->xexpr : Content -> Xexpr
+;; The contract is loosely enforced.
+(define (xml->xexpr x)
+  (let* ((non-dropping-combine
+          (lambda (atts body)
+            (cons (assoc-sort (map attribute->srep atts))
+                  body)))
+         (combine (if (xexpr-drop-empty-attributes)
+                      (lambda (atts body)
+                        (if (null? atts)
+                            body
+                            (non-dropping-combine atts body)))
+                      non-dropping-combine)))
+    (let loop ((x x))
+      (cond
+        ((element? x)
+         (let ((body (map loop (element-content x)))
+               (atts (element-attributes x)))
+           (cons (element-name x) (combine atts body))))
+        ((pcdata? x) (pcdata-string x))
+        ((entity? x) (entity-text x))
+        ((or (comment? x) (pi? x)) x)
+        ((document? x) (error 'xml->xexpr "Expected content, given ~a~nUse document-element to extract the content." x))
+        (else (error 'xml->xexpr "Expected content, given ~a" x))))))
+
+;; attribute->srep : Attribute -> Attribute-srep
+(define (attribute->srep a)
+  (list (attribute-name a) (attribute-value a)))
+
+;; srep->attribute : Attribute-srep -> Attribute
+(define (srep->attribute a)
+  (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
+    (error 'srep->attribute "expected (cons Symbol String) given ~a" a))
+  (make-attribute 'scheme 'scheme (car a) (cadr a)))
+
+;; xexpr->xml : Xexpr -> Content
+;; The contract is enforced.
+(define (xexpr->xml x)
+  (cond
+    ((pair? x)
+     (let ((f (lambda (atts body)
+                (unless (list? body)
+                  (error 'xexpr->xml "expected a list of xexprs a the body in ~a" x))
+                (make-element 'scheme 'scheme (car x)
+                              atts
+                              (map xexpr->xml body)))))
+       (if (and (pair? (cdr x)) (or (null? (cadr x)) (and (pair? (cadr x)) (pair? (caadr x)))))
+           (f (map srep->attribute (cadr x)) (cddr x))
+           (f null (cdr x)))))
+    ((string? x) (make-pcdata 'scheme 'scheme x))
+    ((or (symbol? x) (and (integer? x) (>= x 0))) (make-entity 'scheme 'scheme x))
+    ((or (comment? x) (pi? x)) x)
+    (else (error 'xexpr->xml "malformed xexpr ~s" x))))
+
+;; xexpr->string : Xexpression -> String
+(define (xexpr->string xexpr)
+  (let ((port (open-output-string)))
+    (write-xml/content (xexpr->xml xexpr) port)
+    (get-output-string port)))
+
+;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
+(define (bcompose f g)
+  (lambda (x y) (f (g x) (g y))))

scheme/xml/xml-packages.scm

@@ -0,0 +1,128 @@
+(define-interface xml-structures-interface
+  (export source-start
+	  source-stop
+	  make-location location? location-line location-char location-offset
+	  make-document document? document-prolog document-element document-misc
+	  make-prolog prolog? prolog-misc prolog-dtd prolog-misc2 
+	  make-document-type document-type-name document-type-external 
+	  external-dtd-system external-dtd/system?
+	  make-external-dtd/public external-dtd/public? external-dtd/public-public 
+	  make-external-dtd/system 
+	  make-element element? element-name element-attributes element-content
+	  make-attribute attribute? attribute-name attribute-value
+	  make-pcdata pcdata? pcdata-string
+	  make-entity entity? entity-text
+	  make-pi pi? pi-target-name pi-instruction
+	  make-comment comment? comment-text
+	  content?
+	  make-start-tag start-tag? start-tag-name start-tag-attrs
+	  make-end-tag end-tag? end-tag-name))
+
+(define-structure xml-structures xml-structures-interface
+  (open scheme
+	signals
+	extended-ports
+	define-record-types)
+  (files structures))
+   
+(define-interface plt-compat-interface
+  (export let-values
+	  let*-values
+	  add1 sub1
+	  when unless
+	  begin0
+	  void
+	  andmap
+	  quicksort
+	  make-parameter
+	  let/ec call/ec
+	  list* null
+	  format
+	  fprintf
+	  regexp regexp-replace*
+	  foldr
+	  compose
+	  open-output-string get-output-string
+	  ))
+
+(define-structure plt-compat plt-compat-interface
+  (open scsh
+	scheme
+	string-lib
+	structure-refs)
+  (access big-scheme  ;; format
+	  list-lib)       ;; fold
+  (files plt))
+
+(define-interface reader-interface
+  (export read-xml
+	  read-comments
+	  collapse-whitespace))
+
+(define-structure reader reader-interface
+  (open scsh ;read-string
+	scheme
+	xml-structures
+	i/o
+	i/o-internal
+	ports
+	plt-compat
+	byte-vectors
+	signals)
+  (files reader))
+
+(define-interface writer-interface
+  (export write-xml 
+	  display-xml 
+	  write-xml/content 
+	  display-xml/content 
+	  empty-tag-shorthand 
+	  html-empty-tags))
+   
+(define-structure writer writer-interface
+  (open scheme
+	xml-structures
+	signals
+	plt-compat)
+  (files writer))
+
+
+(define-interface space-interface
+  (export eliminate-whitespace))
+
+(define-structure space space-interface
+  (open scheme
+	plt-compat
+	signals
+	list-lib
+	xml-structures)
+  (files space))
+
+(define-interface xexpr-interface
+  (export xml->xexpr 
+	  xexpr->xml 
+	  xexpr->string 
+	  xexpr-drop-empty-attributes))
+
+(define-structure xexpr xexpr-interface
+  (open scheme
+	plt-compat
+	writer
+	signals
+	xml-structures)
+  (files xexpr))
+
+(define-structure xml (compound-interface xml-structures-interface
+					  reader-interface
+					  writer-interface
+					  xexpr-interface
+					  space-interface)
+  (open scheme
+	plt-compat
+	xml-structures
+	reader
+	writer
+	xexpr
+	space))
+		  
+   

seval.scm

@@ -1,111 +0,0 @@
-;;; Path handler for uploading Scheme code to the SU web server -*- Scheme -*-
-;;; This is really just an handler example demonstrating how to upload code 
-;;; into the server.
-;;; Copyright (c) 1995 by Olin Shivers.
-
-;;; Imports and non-R4RS'isms
-;;;     \r and \n in string for cr and lf.
-;;;	SWITCH conditional, ? for COND
-;;;	HTTP request record stucture
-;;;	HTTP-ERROR & reply codes
-;;;	Basic path handler support
-;;;	scsh syscalls
-;;;     Pretty-printing P proc.
-;;;	htmlout stuff
-;;;	SAFE-EVAL
-;;;	ERROR
-;;;	INDEX
-;;;	URI decoding
-;;;     string hacks (SKIP-WHITESPACE)
-
-;;; HTML forms
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; This path handler is suitable for receiving code entered into an
-;;; HTML text form. The Scheme code being uploaded is being POST'd to us
-;;; (from a form). See http-forms.scm for info on the format of this kind
-;;; of request. After parsing the request into the submitted string, we
-;;; parse *that* into a Scheme sexp with READ, and eval it.
-
-;;; (do/timeout secs thunk)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds.
-;;; Returns nothing useful, and THUNK gets executed in a subprocess,
-;;; so its side-effects are invisible, as well. This is a clever kludge --
-;;; it uses three subprocesses -- but I don't have interrupts, so I'm hosed.
-
-(define (do/timeout* secs thunk)
-  (run (begin (let ((timer  (fork (lambda () (sleep secs))))
-		    (worker (fork thunk)))
-		(receive (process status) (wait-any)
-		  (ignore-errors
-		   (lambda ()
-		     (signal-process (proc:pid (if (eq? worker process)
-						   timer
-						   worker))
-				     signal/kill))))))))
-(define-syntax do/timeout
-  (syntax-rules ()
-    ((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))
-
-
-;;; The path handler for seval ops.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (seval-handler path req)
-  (switch string=? (request:method req)
-    (("POST")	; Could do others also.
-
-     (let ((modern-protocol? (not (v0.9-request? req))))
-       (when modern-protocol?
-         (begin-http-header #t 200)
-	 (write-string "Content-type: text/html\r\n\r\n"))
-       (with-tag #t HEAD ()
-	 (newline)
-         (emit-title #t "Scheme program output"))
-       (newline))
-
-     (with-tag #t BODY ()
-       (newline)
-       (let ((sexp (read-request-sexp req)))
-	 (do/timeout 10
-	   (receive vals
-	            ;; Do the computation.
-	            (begin (emit-header #t 2 "Output from execution")
-			   (newline)
-			   (with-tag #t PRE ()
-			     (newline)
-			     (force-output)	; In case we're gunned down.
-			     (eval-safely sexp)))
-
-	     ;; Pretty-print the returned value(s).
-	     (emit-header #t 2 "Return value(s)")
-	     (with-tag #t PRE ()
-	       (for-each p vals)))))))
-
-      (else (http-error http-reply/method-not-allowed #f req))))
-
-
-;;; Read an HTTP request entity body from stdin. The Content-length:
-;;; element of request REQ's header tells how many bytes to this entity
-;;; is. The entity should be a URI-encoded form body. Pull out the
-;;;     program=<stuff>
-;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
-;;; and return it.
-
-(define (read-request-sexp req)
-  (? ((get-header (request:headers req) 'content-length) =>
-      (lambda (cl-str)		 ; Take the first Content-length: header,
-	(let* ((cl-start (skip-whitespace cl-str))	   ; 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))			; Read in CL chars,
-	       (q (parse-html-form-query qs))		; and parse them up.
-	       (s (? ((assoc "program" q) => cdr)
-		     (else (error "No program in entity body.")))))
-	  (http-log "Seval sexp:~%~s~%" s)
-	  (read (make-string-input-port s)))))
-     (else (http-error http-reply/bad-request req
-		       "No Content-length: field in POST request."))))

start-web-server

@@ -0,0 +1,147 @@
+#!/bin/sh
+echo "Loading..."
+exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
+!#
+
+(define-structure http-test
+  (export main)   
+  (open httpd-core
+	httpd-make-options
+	httpd-basic-handlers
+	httpd-file-directory-handlers
+	cgi-server
+	seval-handler
+	rman-gateway
+	info-gateway
+	let-opt
+        scsh             
+        scheme)          
+                         
+  (begin
+    
+    (define (usage)
+      (format #f 
+"Usage: start-web-server [-h htdocs-dir] [-c cgi-bin-dir] [-p port]
+                        [-l log-file-name] [--help]
+
+ with
+ htdocs-dir     directory of html files (default: web-server/root/htdocs)
+ cgi-bin-dir    directory of cgi files  (default: web-server/root/cgi-bin)
+ port           port server is listening to (default: 8080)
+ log-file-name  directory where to store the logfile in CLF
+                 (default: web-server/httpd.log)
+ --help         show this help
+"
+	      ))
+
+    (define htdocs-dir #f)
+    (define cgi-bin-dir #f)
+    (define port #f)
+    (define log-file-name #f)
+    (define root #f)
+
+    (define (init)
+      (set! htdocs-dir "web-server/root/htdocs")
+      (set! cgi-bin-dir "web-server/root/cgi-bin")
+      (set! port "8080")
+      (set! log-file-name "web-server/httpd.log")
+      (set! root "web-server/root"))
+
+    (define get-options
+      (let* ((unknown-option-error
+	      (lambda (option)
+		(format (error-output-port)
+			"unknown option `~A'~%try `start-web-server --help'~%"
+			option)
+		(exit 1)))
+	     (missing-argument-error
+	      (lambda (option)
+		(format (error-output-port)
+			"option `~A' requires an argument~%try `start-web-server --help'~%"
+			option)
+		(exit 1))))
+	(lambda (options)
+	  (let loop ((options options))
+	    (if (null? options)
+		(begin
+		  (set! htdocs-dir (absolute-file-name htdocs-dir))
+		  (set! log-file-name (absolute-file-name log-file-name))
+		  (set! cgi-bin-dir (absolute-file-name cgi-bin-dir))
+		  (set! port (string->number port)))
+		(cond
+		 ((string=? (car options) "-h")
+		  (if (null? (cdr options))
+		    (missing-argument-error (car options))
+		    (set! htdocs-dir (cadr options)))
+		  (loop (cddr options)))
+		 ((string=? (car options) "-c")
+		  (if (null? (cdr options))
+		    (missing-argument-error (car options))
+		    (set! cgi-bin-dir (cadr options)))
+		  (loop (cddr options)))
+		 ((string=? (car options) "-p")
+		  (if (null? (cdr options))
+		    (missing-argument-error (car options))
+		    (set! port (cadr options)))
+		  (loop (cddr options)))
+		 ((string=? (car options) "-l")
+		  (if (null? (cdr options))
+		    (missing-argument-error (car options))
+		    (set! log-file-name (cadr options)))
+		  (loop (cddr options)))
+		 ((string=? (car options) "--help")
+		  (display (usage))
+		  (exit 0))
+		 ((string=? (car options) "--dump")
+		  (let ((image-name (if (null? (cdr options))
+					"server"
+					(cadr options))))
+		    (dump-scsh-program main image-name))
+		  (exit 0))
+		 (else
+		  (unknown-option-error (car options)))))))))
+
+    
+    (define (main args)
+      (init)
+      (get-options (cdr args))
+      (format #t "options read~%")
+      (cond ((zero? (user-uid))
+	     (set-gid (->gid "nobody"))
+	     (set-uid (->uid "nobody"))))
+
+      (format #t "Going to run Webserver with:
+ htdocs-dir:    ~a
+ cgi-bin-dir:   ~a
+ port:          ~a
+ log-file-name: ~a
+ a maximum of ~a simultaneous requests, syslogging activated, 
+ and home-dir-handler (public_html) activated.
+"
+	      htdocs-dir
+	      cgi-bin-dir
+	      port
+	      log-file-name
+	      5)
+
+      (httpd (with-port			port 
+;	     (with-root-directory	(absolute-file-name "./web-server/root")
+	     (with-simultaneous-requests 5
+	     (with-syslog?		#t
+	     (with-logfile		log-file-name
+	     (with-path-handler 
+	      (alist-path-dispatcher
+	       (list (cons "h" (home-dir-handler "public_html"))
+		     (cons "seval" seval-handler) 
+		     (cons "man" (rman-handler #f "man?%s(%s)" 
+					       "Generated by rman-gateway"))
+		     (cons "info" (info-handler #f #f #f
+						"Generated by info-gateway"))
+		     (cons "cgi-bin" (cgi-handler cgi-bin-dir)))
+	       (rooted-file-or-directory-handler htdocs-dir)))))))))
+))
+;; EOF
+
+;;; Local Variables:
+;;; mode:scheme
+;;; End:

stringhax.scm

@@ -1,63 +0,0 @@
-;;; Random string-hacking procs -*- Scheme -*-
-;;; Copyright (c) 1995 by Olin Shivers.
-
-(define (string-map f s)
-  (let* ((slen (string-length s))
-	 (ns (make-string slen)))
-    (do ((i (- slen 1) (- i 1)))
-	((< i 0) ns)
-      (string-set! ns i (f (string-ref s i))))))
-
-(define (downcase-string s)
-  (string-map char-downcase s))
-
-(define (upcase-string s)
-  (string-map char-upcase s))
-
-
-(define (char-set-index str cset . maybe-start)
-  (let-optionals maybe-start ((start 0))
-    (let ((len (string-length str)))
-      (do ((i start (+ 1 i)))
-	  ((or (>= i len)
-	       (char-set-contains? cset (string-ref str i)))
-	   (and (< i len) i))))))
-
-(define (char-set-rindex str cset . maybe-start)
-  (let ((len (string-length str)))
-    (let-optionals maybe-start ((start len))
-      (do ((i (- start 1) (- i 1)))
-	  ((or (< i 0)
-	       (char-set-contains? cset (string-ref str i)))
-	   (and (>= i 0) i))))))
-
-(define (string-reduce nil cons s)
-  (let ((slen (string-length s)))
-    (do ((ans nil (cons (string-ref s i) ans))
-	 (i 0 (+ i 1)))
-	((= i slen) ans))))
-
-(define (string-prefix? prefix string)
-  (let ((plen (string-length prefix))
-	(slen (string-length string)))
-    (and (<= plen slen)
-	 (let lp ((i 0))
-	   (or (= i plen)
-	       (and (char=? (string-ref prefix i)
-			    (string-ref string i))
-		    (lp (+ i 1))))))))
-
-(define (string-suffix? suffix string)
-  (let ((slen (string-length suffix))
-	(len (string-length string)))
-    (and (<= slen len)
-	 (let lp ((i (- slen 1))
-		  (j (-  len 1)))
-	   (or (< i 0)
-	       (and (char=? (string-ref suffix i)
-			    (string-ref string j))
-		    (lp (- i 1) (- j 1))))))))
-
-(define skip-whitespace
-  (let ((non-whitespace (char-set-invert char-set:whitespace)))
-    (lambda (s) (char-set-index s non-whitespace))))

toothless.scm

@@ -1,58 +0,0 @@
-;;; -*- Scheme -*-
-;;; This file defines a Scheme 48 module that is R4RS without features that
-;;; could examine or effect the file system. You can also use it
-;;; as a model of how to execute code in other protected environments
-;;; in S48.
-;;;
-;;; Copyright (c) 1995 by Olin Shivers.
-
-(define-structure loser-package (export loser)
-  (open scheme error-package)
-  (begin (define (loser name)
-	   (lambda x (error "Illegal call" name)))))
-
-;;; The toothless structure is R4RS without the dangerous procedures.
-
-(define-structure toothless (interface-of scheme)
-  (open scheme loser-package)
-  (begin
-    (define call-with-input-file	(loser "call-with-input-file"))
-    (define call-with-output-file	(loser "call-with-output-file"))
-    (define load			(loser "load"))
-    (define open-input-file		(loser "open-input-file"))
-    (define open-output-file		(loser "open-output-file"))
-    (define transcript-on		(loser "transcript-on"))
-    (define with-input-from-file	(loser "with-input-from-file"))
-    (define with-input-to-file		(loser "with-input-to-file"))
-    (define eval			(loser "eval"))
-    (define interaction-environment	(loser "interaction-environment"))
-    (define scheme-report-environment	(loser "scheme-report-environment"))))
-
-;;; (EVAL-SAFELEY exp)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Create a brand new package, import the TOOTHLESS structure, and
-;;; evaluate EXP in it. When the evaluation is done, you throw away
-;;; the environment, so EXP's side-effects don't persist from one 
-;;; EVAL-SAFELY call to the next. If EXP raises an error exception,
-;;; we abort and return #f.
-
-(define-structure toothless-eval (export eval-safely)
-  (open evaluation			; eval
-	package-commands-internal	; config-package, get-reflective-tower
-	packages			; structure-package, make-simple-package
-	environments			; environment-ref
-	handle				; ignore-errors
-	scheme)
-  (access toothless)	; Force it to be loaded.
-  (begin
-
-    (define toothless-struct (environment-ref (config-package) 'toothless))
-    (define toothless-package (structure-package toothless-struct))
-
-    (define (new-safe-package)
-      (make-simple-package (list toothless-struct) #t
-			   (get-reflective-tower toothless-package) ; ???
-			   'safe-env))
-
-    (define (eval-safely exp)
-      (ignore-errors (lambda () (eval exp (new-safe-package)))))))

web-server/.gitignore

@@ -0,0 +1 @@
+httpd.log

web-server/root/cgi-bin/comments.sh

@@ -0,0 +1,8 @@
+#!/bin/sh
+echo Content-Type: text/html
+echo Status: 200 OK
+echo 
+echo "<h2> This is the cgi script. </h2>"
+echo "<br> Current date: "
+echo `date`
+echo

web-server/root/htdocs/files/text.txt

@@ -0,0 +1 @@
+This is a text file.

web-server/root/htdocs/index.html

@@ -0,0 +1,8 @@
+<html>
+<head><title>Home</title></head>
+<body>
+<p>
+Hello world! <a href=index2.html>(more...)</a>
+</p>
+</body>
+</html>

web-server/root/htdocs/index2.html

@@ -0,0 +1,38 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+  <head><title>Scheme Unterground</title></head>
+  <body>
+    <p>
+    <h1>Hello Unterground!</h1>
+    
+    Following files are available:
+    <ul>
+      <li><a href=../cgi-bin/comments.sh>A small CGI script</a></li>
+      <li><a href=seval.html>Computing Scheme Forms
+	  Interactively</a></li>
+      <li><a href=man?man>Get a man page</a><br>
+	  (needs a matching man page installation;<br>
+	&nbsp;see httpd/rman-gateway.scm for details)</li>
+      <li><a href=info?(dir)Top>Get the dir info page</a><br>
+	  (needs a matching info page installation;<br>
+	  &nbsp;among others, we need non-gzipped info pages)</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>Start</a></li>
+      <li><a href=index2.html>This file</a></li>
+    </ul>
+    <br>
+    And nothing else...
+    
+    <hr>
+    <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
+    <!-- hhmts start -->
+Last modified: Thu Aug 29 16:37:20 CEST 2002
+<!-- hhmts end -->
+  </body>
+</html>
+  
+</p>
+</body>
+</html>

web-server/root/htdocs/seval.html

@@ -0,0 +1,25 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+  <head>
+    <title>Evaluating Scheme Expressions Interactively</title>
+  </head>
+
+  <body>
+    <h1>Evaluating Scheme Expressions Interactively</h1>
+
+    <form action="seval" method="post">
+      Type in your scheme expression as you would at any REPL:
+      <br>
+      <input type="text" name="program">
+      <input type="submit">
+      <input type="reset">
+    </form>
+
+    <hr>
+    <address><a href="mailto:andreas.bernauer@gmx.de">Andreas Bernauer</a></address>
+<!-- Created: Wed Aug 28 16:35:32 CEST 2002 -->
+<!-- hhmts start -->
+Last modified: Wed Aug 28 16:40:54 CEST 2002
+<!-- hhmts end -->
+  </body>
+</html>