Sync with the WSI repository

Makefile

@@ -0,0 +1,42 @@
+SHELL = /bin/sh
+
+version_id = 1.0
+
+TEMPDIR = /tmp
+
+sunet_files = ChangeLog \
+	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)

ftpd.scm

@@ -0,0 +1,779 @@
+; RFC 959 ftp daemon
+
+; Mike Sperber <sperber@informatik.uni-tuebingen.de>
+; Copyright (c) 1998 Michael Sperber.
+
+; It doesn't support the following desirable things:
+;
+; - Login by user; this requires crypt which scsh doesn't have
+; - RESTART support
+; - Banners from files on CWD
+; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
+
+(define (ftpd . maybe-port)
+  (let ((port (optional maybe-port 21)))
+    (bind-listen-accept-loop
+     protocol-family/internet
+     (lambda (socket address)
+       
+       (set-ftp-socket-options! socket)
+       
+       (fork
+	(lambda ()
+	  (handle-connection (socket:inport socket) 
+			     (socket:outport socket))
+	  (reap-zombies)
+	  (shutdown-socket socket shutdown/sends+receives))))
+     
+     port)))
+
+(define (ftpd-inetd)
+  (handle-connection (current-input-port)
+		     (current-output-port)))
+
+(define (set-ftp-socket-options! socket)
+  ;; If the client closes the connection, we won't lose when we try to
+  ;; close the socket by trying to flush the output buffer.
+  (set-port-buffering (socket:outport socket) bufpol/none)
+
+  (set-socket-option socket level/socket socket/oob-inline #t))
+
+; We're stateful anyway, so what the hell ...
+
+(define *control-input-port* #f)
+(define *control-output-port* #f)
+
+(define (handle-connection input-port output-port)
+  (call-with-current-continuation
+   (lambda (escape)
+     (with-handler
+      (lambda (condition more)
+	(escape 'fick-dich-ins-knie))
+      (lambda ()
+	(set! *control-input-port* input-port)
+	(set! *control-output-port* output-port)
+	(display-banner)
+	(handle-commands))))))
+
+(define (display-banner)
+  (register-reply! 220
+		   (string-append
+		    "Scheme Untergrund ftp server ("
+		    *ftpd-version*
+		    ") ready.")))
+
+(define-condition-type 'ftpd-quit '())
+(define ftpd-quit? (condition-predicate 'ftpd-quit))
+
+(define-condition-type 'ftpd-error '())
+(define ftpd-error? (condition-predicate 'ftpd-error))
+
+(define (handle-commands)
+  (with-handler
+   (lambda (condition more)
+     ;; this in really only for ftpd-quit
+     (write-replies)
+     (more))
+   (lambda ()
+     (let loop ()
+       (write-replies)
+       (accept-command)
+       (loop)))))
+
+(define (accept-command)
+  (let ((command-line (read-crlf-line *control-input-port*)))
+    ;; (format #t "Command line: ~A~%" command-line)
+    (call-with-values
+     (lambda () (parse-command-line command-line))
+     (lambda (command arg)
+       (handle-command command arg)))))
+
+(define (handle-command command arg)
+  (call-with-current-continuation
+   (lambda (escape)
+     (with-handler
+      (lambda (condition more)
+	(cond
+	 ((error? condition)
+	  (register-reply! 451
+			   (format #f "Internal error: ~S"
+				   (condition-stuff condition)))
+	  (escape 'fick-dich-ins-knie))
+	 ((ftpd-error? condition)
+	  (escape 'fick-dich-ins-knie))
+	 (else
+	  (more))))
+      (lambda ()
+	(with-errno-handler*
+	 (lambda (errno packet)
+	   (register-reply! 451
+			    (format #f "Unix error: ~A." (car packet)))
+	   (escape 'fick-dich-ins-knie))
+	 (lambda ()
+	   (dispatch-command command arg))))))))
+
+(define (dispatch-command command arg)
+  (cond
+   ((assoc command *command-alist*)
+    => (lambda (pair)
+	 ((cdr pair) arg)))
+   (else
+    (register-reply! 500
+		     (string-append
+		      (format #f "Unknown command: \"~A\"" command)
+		      (if (string=? "" arg)
+			  "."
+			  (format #f " (argument(s) \"~A\")." arg)))))))
+
+(define *logged-in?* #f)
+(define *authenticated?* #f)
+(define *anonymous?* #f)
+(define *root-directory* #f)
+(define *current-directory* "")
+
+(define (handle-user name)
+  (cond
+   (*logged-in?*
+    (register-reply! 230
+		     "You are already logged in."))
+   ((or (string=? "anonymous" name)
+	(string=? "ftp" name))
+    (handle-user-anonymous))
+   (else
+    (register-reply! 530
+		     "Only anonymous logins allowed."))))
+
+(define (handle-user-anonymous)
+  (let ((ftp-info (user-info "ftp")))
+
+    (set-gid (user-info:gid ftp-info))
+    (set-uid (user-info:uid ftp-info))
+
+    (set! *logged-in?* #t)
+    (set! *authenticated?* #t)
+    (set! *anonymous?* #t)
+    (set! *root-directory* (file-name-as-directory (user-info:home-dir ftp-info)))
+    (set! *current-directory* "")
+
+    (register-reply! 230 "Anonymous user logged in.")))
+
+(define (handle-pass password)
+  (cond
+   ((not *logged-in?*)
+    (register-reply! 530 "You have not logged in yet."))
+   (*anonymous?*
+    (register-reply! 200 "Thank you."))
+   (else
+    (register-reply! 502 "This can't happen."))))
+
+(define (handle-quit foo)
+  (register-reply! 221 "Goodbye!  Au revoir!  Auf Wiedersehen!")
+  (signal 'ftpd-quit))
+
+(define (handle-syst foo)
+  (register-reply! 215 "UNIX Type: L8"))
+
+(define (handle-cwd path)
+  (ensure-authenticated-login)
+  (let ((current-directory (assemble-path path)))
+    (with-errno-handler*
+     (lambda (errno packet)
+       (signal-error! 550
+			(format #f "Can't change directory to \"~A\": ~A."
+				path
+				(car packet))))
+     (lambda ()
+       (with-cwd*
+	(file-name-as-directory
+	 (string-append *root-directory* current-directory))
+	(lambda ()			; I hate gratuitous syntax
+	  (set! *current-directory* current-directory)
+	  (register-reply! 250
+			   (format #f "Current directory changed to \"/~A\"."
+				   current-directory))))))))
+
+(define (handle-cdup foo)
+  (handle-cwd ".."))
+
+(define (handle-pwd foo)
+  (ensure-authenticated-login)
+  (register-reply! 257
+		   (format #f "Current directory is \"/~A\"."
+			   *current-directory*)))
+
+
+(define (make-file-action-handler error-format-string action)
+  (lambda (path)
+    (ensure-authenticated-login)
+    (if (string=? "" path)
+	(signal-error! 500 "No argument."))
+    (let ((full-path (string-append *root-directory*
+				    (assemble-path path))))
+      (with-errno-handler*
+       (lambda (errno packet)
+	 (signal-error! 550
+			(format #f error-format-string
+				path (car packet))))
+       (lambda ()
+	 (action path full-path))))))
+
+(define handle-dele
+  (make-file-action-handler
+   "Could not delete \"~A\": ~A."
+   (lambda (path full-path)
+     (delete-file full-path)
+     (register-reply! 250 (format #f "Deleted \"~A\"." path)))))
+
+(define handle-mdtm
+  (make-file-action-handler
+   "Could not get info on \"~A\": ~A."
+   (lambda (path full-path)
+     (let* ((info (file-info full-path))
+	    (the-date (date (file-info:mtime info) 0)))
+       (register-reply! 213
+			(format-date "~Y~m~d~H~M~S" the-date))))))
+
+(define handle-mkd
+  (make-file-action-handler
+   "Could not make directory \"~A\": ~A."
+   (lambda (path full-path)
+     (create-directory full-path #o755)
+     (register-reply! 257
+		      (format #f "Created directory \"~A\"." path)))))
+
+(define handle-rmd
+  (make-file-action-handler
+   "Could not remove directory \"~A\": ~A."
+   (lambda (path full-path)
+     (delete-directory full-path)
+     (register-reply! 250
+		      (format #f "Deleted directory \"~A\"." path)))))
+
+(define *to-be-renamed* #f)
+
+(define handle-rnfr
+  (make-file-action-handler
+   "Could not get info on file \"~A\": ~A."
+   (lambda (path full-path)
+     (file-info full-path)
+     (register-reply! 350 "RNFR accepted.  Gimme a RNTO next.")
+     (set! *to-be-renamed* full-path))))
+
+(define (handle-rnto path)
+  (ensure-authenticated-login)
+  (if (not *to-be-renamed*)
+      (signal-error! 503 "Need RNFR before RNTO."))
+  (if (string=? "" path)
+      (signal-error! 500 "No argument."))
+  (let ((full-path (string-append *root-directory*
+				  (assemble-path path))))
+
+    (if (file-exists? full-path)
+	(signal-error!
+	 550
+	 (format #f "Rename failed---\"~A\" already exists or is protected."
+		 path)))
+
+    (with-errno-handler*
+     (lambda (errno packet)
+       (signal-error! 550
+		      (format #f "Could not rename: ~A." path)))
+     (lambda ()
+       (rename-file *to-be-renamed* full-path)
+       (register-reply! 250 "File renamed.")
+       (set! *to-be-renamed* #f)))))
+  
+(define handle-size
+  (make-file-action-handler
+   "Could not get info on file \"~A\": ~A."
+   (lambda (path full-path)
+     (let ((info (file-info full-path)))
+       (if (not (eq? 'regular (file-info:type info)))
+	   (signal-error! 550
+			  (format #f "\"~A\" is not a regular file."
+				  path)))
+       (register-reply! 213 (number->string (file-info:size info)))))))
+
+(define *type* 'ascii)
+
+(define (handle-type arg)
+  (cond
+   ((string-ci=? "A" arg)
+    (set! *type* 'ascii))
+   ((string-ci=? "I" arg)
+    (set! *type* 'image))
+   ((string-ci=? "L8" arg)
+    (set! *type* 'image))
+   (else
+    (signal-error! 504
+		   (format #f "Unknown TYPE: ~A." arg))))
+
+  (register-reply! 200
+		   (format #f "TYPE is now ~A."
+			   (case *type*
+			     ((ascii) "ASCII")
+			     ((image) "8-bit binary")
+			     (else "somethin' weird, man")))))
+
+(define (handle-mode arg)
+  (cond
+   ((string=? "" arg)
+    (register-reply! 500
+		     "No arguments.  Not to worry---I'd ignore them anyway."))
+   ((string-ci=? "S" arg)
+    (register-reply! 200 "Using stream mode to transfer files."))
+   (else
+    (register-reply! 504 (format #f "Mode \"~A\" is not supported."
+				 arg)))))
+
+(define (handle-stru arg)
+  (cond
+   ((string=? "" arg)
+    (register-reply! 500
+		     "No arguments.  Not to worry---I'd ignore them anyway."))
+   ((string-ci=? "F" arg)
+    (register-reply! 200 "Using file structure to transfer files."))
+   (else
+    (register-reply! 504
+		     (format #f "File structure \"~A\" is not supported."
+			     arg)))))
+
+(define (handle-noop arg)
+  (register-reply! 200 "Done nothing, but successfully."))
+
+(define *port-arg-regexp*
+  (make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))
+
+(define (parse-port-arg string)
+  (cond
+   ((regexp-exec *port-arg-regexp* string)
+    => (lambda (match)
+	 (let ((components
+		(map (lambda (match-index)
+		       (string->number
+			(match:substring match match-index)))
+		     '(1 2 3 4 5 6))))
+	   (if (any? (lambda (component)
+		       (> component 255))
+		     components)
+	       (signal-error! 501
+			      "Invalid arguments to PORT."))
+	   (apply
+	    (lambda (a1 a2 a3 a4 p1 p2)
+	      (values (+ (arithmetic-shift a1 24)
+			 (arithmetic-shift a2 16)
+			 (arithmetic-shift a3 8)
+			 a4)
+		      (+ (arithmetic-shift p1 8)
+			 p2)))
+	    components))))
+   (else
+    (signal-error! 500
+		   "Syntax error in argument to PORT."))))
+
+(define *data-socket* #f)
+
+(define (handle-port stuff)
+  (ensure-authenticated-login)
+  (maybe-close-data-connection)
+  (call-with-values
+   (lambda () (parse-port-arg stuff))
+   (lambda (address port)
+     (let ((socket (create-socket protocol-family/internet
+				  socket-type/stream)))
+
+       (set-socket-option socket level/socket socket/reuse-address #t)
+
+       (connect-socket socket
+		       (internet-address->socket-address
+			address port))
+       
+       (set! *data-socket* socket)
+
+       (register-reply! 200
+			(format #f "Connected to ~A, port ~A."
+				(format-internet-host-address address)
+				port))))))
+
+(define *passive-socket* #f)
+
+(define (handle-pasv stuff)
+  (ensure-authenticated-login)
+  (maybe-close-data-connection)
+  (let ((socket (create-socket protocol-family/internet
+			       socket-type/stream)))
+    
+    (set-socket-option socket level/socket socket/reuse-address #t)
+
+    ;; kludge
+    (bind-socket socket
+		 (internet-address->socket-address (this-host-address)
+						   0))
+    (listen-socket socket 1)
+
+    (let ((address (socket-local-address socket)))
+
+      (call-with-values
+       (lambda () (socket-address->internet-address address))
+       (lambda (host-address port)
+
+	 (set! *passive-socket* socket)
+
+	 (register-reply! 227
+			  (format #f "Passive mode OK (~A,~A)"
+				  (format-internet-host-address host-address ",")
+				  (format-port port))))))))
+
+; This doesn't look right.  But I can't look into the socket of the
+; control connection if we're running under inetd---there's no way to
+; coerce a port to a socket as there is in C.
+
+(define (this-host-address)
+  (car (host-info:addresses (host-info (system-name)))))
+
+(define (format-internet-host-address address . maybe-separator)
+
+  (define (extract shift)
+    (number->string
+     (bitwise-and (arithmetic-shift address (- shift))
+		  255)))
+
+  (let ((separator (optional maybe-separator ".")))
+    (string-append
+     (extract 24) separator (extract 16) separator
+     (extract 8) separator (extract 0))))
+
+(define (format-port port)
+  (string-append
+   (number->string (bitwise-and (arithmetic-shift port -8) 255))
+   ","
+   (number->string (bitwise-and port 255))))
+
+(define (handle-nlst arg)
+  (handle-listing arg '()))
+
+(define (handle-list arg)
+  (handle-listing arg '(long)))
+  
+(define (handle-listing arg preset-flags)
+  (ensure-authenticated-login)
+  (with-data-connection
+   (lambda ()
+     (let ((args (split-arguments arg)))
+       (call-with-values
+	(lambda ()
+	  (partition-list
+	   (lambda (arg)
+	     (and (not (string=? "" arg))
+		  (char=? #\- (string-ref arg 0))))
+	   args))
+	(lambda (flag-args rest-args)
+
+	  (if (and (not (null? rest-args))
+		   (not (null? (cdr rest-args))))
+	      (signal-error! 501 "More than one path argument."))
+
+	  (let ((path (if (null? rest-args)
+			  ""
+			  (car rest-args)))
+		(flags (arguments->ls-flags flag-args)))
+
+	    (if (not flags)
+		(signal-error! 501 "Invalid flag(s)."))
+
+	    (generate-listing path (append preset-flags flags)))))))))
+
+; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
+; ENSURE-DATA-CONNECTION.
+
+(define (generate-listing path flags)
+  (let ((full-path (string-append *root-directory*
+				  (assemble-path path))))
+    (with-errno-handler*
+     (lambda (errno packet)
+       (signal-error! 451
+		      (format #f "Can't access directory at ~A: ~A."
+			      path
+			      (car packet))))
+     (lambda ()
+       (ls flags (list full-path) (socket:outport *data-socket*))))))
+
+(define (handle-abor foo)
+  (maybe-close-data-connection)
+  (register-reply! 226 "Closing data connection."))
+
+(define (handle-retr path)
+  (ensure-authenticated-login)
+  (let ((full-path (string-append *root-directory*
+				  (assemble-path path))))
+    (with-fatal-error-handler*		; CALL-WITH-INPUT-FILE doesn't go through ERRNO
+     (lambda (condition more)
+       (signal-error! 550
+		      (format #f "Can't open \"~A\" for reading."
+			      path)))
+     (lambda ()
+       (let ((info (file-info full-path)))
+	 (if (not (eq? 'regular (file-info:type info)))
+	     (signal-error! 450
+			    (format #f "\"~A\" is not a regular file."
+				    path)))
+	 (call-with-input-file full-path
+	   (lambda (file-port)
+	     (with-data-connection
+	      (lambda ()
+		(case *type*
+		  ((image)
+		   (copy-port->port-binary
+		    file-port
+		    (socket:outport *data-socket*)))
+		  ((ascii)
+		   (copy-port->port-ascii
+		    file-port
+		    (socket:outport *data-socket*)))))))))))))
+
+(define (handle-stor path)
+  (ensure-authenticated-login)
+  (let ((full-path (string-append *root-directory*
+				  (assemble-path path))))
+    (with-fatal-error-handler*
+     (lambda (condition more)
+       (signal-error! 550
+		      (format #f "Can't open \"~A\" for writing."
+			      path)))
+     (lambda ()
+       (call-with-output-file full-path
+	 (lambda (file-port)
+	   (with-data-connection
+	    (lambda ()
+	      (case *type*
+		((image)
+		 (copy-port->port-binary
+		  (socket:inport *data-socket*)
+		  file-port))
+		((ascii)
+		 (copy-ascii-port->port
+		  (socket:inport *data-socket*)
+		  file-port)))))))))))
+  
+(define (assemble-path path)
+  (let* ((interim-path
+	  (if (not (file-name-rooted? path))
+	      (string-append (file-name-as-directory *current-directory*)
+			     path)
+	      path))
+	 (complete-path (if (file-name-rooted? interim-path)
+			    (file-name-sans-rooted interim-path)
+			    interim-path)))
+    (cond
+     ((normalize-path complete-path)
+      => (lambda (assembled-path) assembled-path))
+     (else
+      (signal-error! 501 "Invalid pathname")))))
+
+(define (ensure-authenticated-login)
+  (if (or (not *logged-in?*)
+	  (not *authenticated?*))
+      (signal-error! 530 "You're not logged in yet.")))
+
+(define (with-data-connection thunk)
+  (dynamic-wind ensure-data-connection
+		thunk
+		maybe-close-data-connection))
+  
+(define *window-size* 51200)
+
+(define (ensure-data-connection)
+  (if (and (not *data-socket*) (not *passive-socket*))
+      (signal-error! 425 "No data connection."))
+
+  (if *passive-socket*
+      (call-with-values
+       (lambda () (accept-connection *passive-socket*))
+       (lambda (socket socket-address)
+	 (set! *data-socket* socket))))
+
+  (register-reply! 150 "Opening data connection.")
+  (write-replies)
+
+  (set-socket-option *data-socket* level/socket
+		     socket/send-buffer *window-size*)
+  (set-socket-option *data-socket* level/socket
+		     socket/receive-buffer *window-size*))
+
+(define (maybe-close-data-connection)
+  (if (or *data-socket* *passive-socket*)
+      (close-data-connection)))
+
+(define (close-data-connection)
+  (if *data-socket*
+      (close-socket *data-socket*))
+  (if *passive-socket*
+      (close-socket *passive-socket*))
+  (register-reply! 226 "Closing data connection.")
+  (set! *data-socket* #f)
+  (set! *passive-socket* #f))
+
+(define *command-alist*
+  (list
+   (cons "NOOP" handle-noop)
+   (cons "USER" handle-user)
+   (cons "PASS" handle-pass)
+   (cons "QUIT" handle-quit)
+   (cons "SYST" handle-syst)
+   (cons "CWD" handle-cwd)
+   (cons "PWD" handle-pwd)
+   (cons "CDUP" handle-cdup)
+   (cons "DELE" handle-dele)
+   (cons "MDTM" handle-mdtm)
+   (cons "MKD" handle-mkd)
+   (cons "RMD" handle-rmd)
+   (cons "RNFR" handle-rnfr)
+   (cons "RNTO" handle-rnto)
+   (cons "SIZE" handle-size)
+   (cons "TYPE" handle-type)
+   (cons "MODE" handle-mode)
+   (cons "STRU" handle-stru)
+   (cons "PORT" handle-port)
+   (cons "PASV" handle-pasv)
+   (cons "NLST" handle-nlst)
+   (cons "LIST" handle-list)
+   (cons "RETR" handle-retr)
+   (cons "STOR" handle-stor)
+   (cons "ABOR" handle-abor)))
+
+(define (parse-command-line line)
+  (if (eof-object? line) ; Netscape does this
+      (values "QUIT" "")
+      (let* ((line (trim-spaces line))
+	     (split-position (index line #\space)))
+	(if split-position
+	    (values (upcase-string (substring line 0 split-position))
+		    (trim-spaces (substring line
+					    (+ 1 split-position)
+					    (string-length line))))
+	    (values (upcase-string line) "")))))
+
+; Path names
+
+; This removes all internal ..'s from a path.
+; NORMALIZE-PATH returns #f if PATH points to a parent directory.
+
+(define (normalize-path path)
+  (let loop ((components (split-file-name (simplify-file-name path)))
+	     (reverse-result '()))
+    (cond
+     ((null? components)
+      (path-list->file-name (reverse reverse-result)))
+     ((null? (cdr components))
+      (if (string=? ".." (car components))
+	  #f
+	  (path-list->file-name
+	   (reverse (cons (car components) reverse-result)))))
+     ((string=? ".." (cadr components))
+      (loop (cddr components) reverse-result))
+     (else
+      (loop (cdr components) (cons (car components) reverse-result))))))
+
+(define (file-name-rooted? file-name)
+  (and (not (string=? "" file-name))
+       (char=? #\/ (string-ref file-name 0))))
+
+(define (file-name-sans-rooted file-name)
+  (substring file-name 1 (string-length file-name)))
+
+(define split-arguments
+  (infix-splitter " +"))
+
+; Reply handling
+
+; Replies must be synchronous with requests and actions.  Therefore,
+; they are queued on generation via REGISTER-REPLY!.  The messages are
+; printed via WRITE-REPLIES.  For the nature of the replies, see RFC
+; 959.
+
+(define *reverse-replies* '())
+(define *reply-code* #f) ; the last one wins
+
+(define (write-replies)
+  (if (not (null? *reverse-replies*))
+      (let loop ((messages (reverse *reverse-replies*)))
+	(if (null? (cdr messages))
+	    (write-final-reply (car messages))
+	    (begin
+	      (write-nonfinal-reply (car messages))
+	      (loop (cdr messages))))))
+  (set! *reverse-replies* '()))
+
+(define (write-final-reply line)
+  (format *control-output-port* "~D ~A" *reply-code* line)
+  ;; (format #t "Reply: ~D ~A~%" *reply-code* line)
+  (write-crlf *control-output-port*))
+
+(define (write-nonfinal-reply line)
+  (format *control-output-port* "~D-~A" *reply-code* line)
+  ;; (format #t "Reply: ~D-~A~%" *reply-code* line)
+  (write-crlf *control-output-port*))
+
+(define (signal-error! code message)
+  (register-reply! code message)
+  (signal 'ftpd-error))
+
+(define (register-reply! code message)
+  (set! *reverse-replies* 
+	(cons message *reverse-replies*))
+  (set! *reply-code* code))
+
+; Version
+
+(define *ftpd-version* "$Revision: 1.1 $")
+
+(define (copy-port->port-binary input-port output-port)
+  (let ((buffer (make-string *window-size*)))
+    (let loop ()
+      (cond
+       ((read-string! buffer input-port)
+	=> (lambda (length)
+	     (write-string buffer output-port 0 length)
+	     (loop))))))
+  (force-output output-port))
+
+(define (copy-port->port-ascii input-port output-port)
+  (let loop ()
+    (let ((line (read-line input-port 'concat)))
+      (if (not (eof-object? line))
+	  (let ((length (string-length line)))
+	    (cond
+	     ((zero? length)
+	      'fick-dich-ins-knie)
+	     ((char=? #\newline (string-ref line (- length 1)))
+	      (write-string line output-port 0 (- length 1))
+	      (write-crlf output-port))
+	     (else
+	      (write-string line output-port)))
+	    (loop)))))
+  (force-output output-port))
+
+(define (copy-ascii-port->port input-port output-port)
+  (let loop ()
+    (let* ((line (read-crlf-line input-port))
+	   (length (string-length line)))
+      (if (not (eof-object? line))
+	  (begin
+	    (write-string line output-port 0 length)
+	    (newline output-port)
+	    (loop)))))
+  (force-output output-port))
+
+; Utilities
+
+(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))))
+
+; Stuff from Big Scheme
+; We can't open BIG-SCHEME because we use virgin SIGNALS.  Sigh.
+
+(define any? (structure-ref big-scheme any?))
+(define partition-list (structure-ref big-scheme partition-list))

handle-fatal-error.scm

@@ -0,0 +1,92 @@
+;;; Handle fatal errors in a sensible way. -*- Scheme -*-
+;;; Copyright (c) 1995 by Olin Shivers.
+
+;;; (with-fatal-error-handler* handler thunk)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
+;;; and that condition is an error condition (or a subtype of error), then
+;;; HANDLER gets a chance to handle it.
+;;; The HANDLER proc is applied to two values: 
+;;;     (HANDLER condition decline)
+;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
+;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
+;;; handle the error by throwing to DECLINE, a nullary continuation.
+;;;
+;;; Why is it called with-FATAL-error-handler*? Because returning to the
+;;; guy that signalled the error is not an option.
+;;;
+;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
+;;; error handler *itself* raises an error? This could potentially give
+;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
+;;; the original condition-signaller's context, so you'd search back for a
+;;; handler, and find yourself again. For example, here is an infinite loop:
+;;;
+;;;   (with-handler (lambda (condition more)
+;;;                   (display "Loop!")
+;;;                   (error "ouch"))	; Get back, Loretta.
+;;;     (lambda () (error "start me up")))
+;;;
+;;; I could require W-F-E-H* users to code carefully, but instead I make sure
+;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
+;;; if it signals a condition, we'll start the search from there. That's the
+;;; point of continuation K. When the original thunk completes successfully,
+;;; we dodge the K hackery by using ACCEPT to make a normal return.
+
+(define (with-fatal-error-handler* handler thunk)
+  (call-with-current-continuation
+    (lambda (accept)
+      ((call-with-current-continuation
+         (lambda (k)
+	   (with-handler (lambda (condition more)
+			   (if (error? condition)
+			       (call-with-current-continuation
+				 (lambda (decline)
+				   (k (lambda () (handler condition decline))))))
+			   (more))	; Keep looking for a handler.
+	      (lambda () (call-with-values thunk accept)))))))))
+		  
+(define-syntax with-fatal-error-handler 
+  (syntax-rules ()
+    ((with-fatal-error-handler handler body ...)
+     (with-fatal-error-handler* handler
+       (lambda () body ...)))))
+
+;This one ran HANDLER in the signaller's condition-handler context.
+;It was therefore susceptible to infinite loops if you didn't code 
+;your handler's carefully.
+;
+;(define (with-fatal-error-handler* handler thunk)
+;  (call-with-current-continuation
+;    (lambda (accept)
+;      (with-handler (lambda (condition more)
+;		      (if (error? condition)
+;			  (call-with-current-continuation
+;		            (lambda (decline)
+;			      (accept (handler condition decline)))))
+;		      (more))	; Keep looking for a handler.
+;        thunk))))
+
+;;; (%error-handler-cond kont eh-clauses cond-clauses)
+;;; Transform error-handler clauses into COND clauses by wrapping continuation
+;;; KONT around the body of each e-h clause, so that if it fires, the result
+;;; is thrown to KONT, but if no clause fires, the cond returns to the default
+;;; continuation.
+
+;(define-syntax %error-handler-cond
+;  (syntax-rules (=> else)
+;
+;   ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
+;    (%error-handler-cond kont
+;			 (clause ...)
+;			 ((test => (lambda (v) (kont (proc v)))) ans ...)))
+;
+;   ((%error-handler-cond kont ((test body ...) clause ...) (ans ...))
+;    (%error-handler-cond kont
+;			 (clause ...)
+;			 ((test (kont (begin body ...))) ans ...)))
+;
+;   ((%error-handler-cond kont ((else body ...)) (ans-clause ...))
+;    (cond (else body ...) ans-clause ...))
+;
+;   ((%error-handler-cond kont () (ans-clause ...))
+;    (cond ans-clause ...))))

httpd-access-control.scm

@@ -26,11 +26,9 @@
 (define (access-controller . controls)
   (lambda (info)
     (let loop ((controls controls))
-      (if (null? controls)
+      (and (pair? controls)
-	  #f
+	   (or ((car controls) info)
-	  (cond
+	       (loop (cdr controls)))))))
-	   (((car controls) info) => identity)
-	   (else (loop (cdr controls))))))))
 
 (define (access-controlled-handler control ph)
   (lambda (path req)

httpd-error.scm

@@ -6,10 +6,6 @@
 ;;; 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
@@ -39,93 +35,3 @@
 (define (fatal-syntax-error msg . irritants)
   (apply signal 'fatal-syntax-error msg irritants))
 
-
-;;; (with-fatal-error-handler* handler thunk)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
-;;; and that condition is an error condition (or a subtype of error), then
-;;; HANDLER gets a chance to handle it.
-;;; The HANDLER proc is applied to two values: 
-;;;     (HANDLER condition decline)
-;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
-;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
-;;; handle the error by throwing to DECLINE, a nullary continuation.
-;;;
-;;; Why is it called with-FATAL-error-handler*? Because returning to the
-;;; guy that signalled the error is not an option.
-;;;
-;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
-;;; error handler *itself* raises an error? This could potentially give
-;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
-;;; the original condition-signaller's context, so you'd search back for a
-;;; handler, and find yourself again. For example, here is an infinite loop:
-;;;
-;;;   (with-handler (lambda (condition more)
-;;;                   (display "Loop!")
-;;;                   (error "ouch"))	; Get back, Loretta.
-;;;     (lambda () (error "start me up")))
-;;;
-;;; I could require W-F-E-H* users to code carefully, but instead I make sure
-;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
-;;; if it signals a condition, we'll start the search from there. That's the
-;;; point of continuation K. When the original thunk completes successfully,
-;;; we dodge the K hackery by using ACCEPT to make a normal return.
-
-(define (with-fatal-error-handler* handler thunk)
-  (call-with-current-continuation
-    (lambda (accept)
-      ((call-with-current-continuation
-         (lambda (k)
-	   (with-handler (lambda (condition more)
-			   (if (error? condition)
-			       (call-with-current-continuation
-				 (lambda (decline)
-				   (k (lambda () (handler condition decline))))))
-			   (more))	; Keep looking for a handler.
-	      (lambda () (call-with-values thunk accept)))))))))
-		  
-(define-syntax with-fatal-error-handler 
-  (syntax-rules ()
-    ((with-fatal-error-handler handler body ...)
-     (with-fatal-error-handler* handler
-       (lambda () body ...)))))
-
-;This one ran HANDLER in the signaller's condition-handler context.
-;It was therefore susceptible to infinite loops if you didn't code 
-;your handler's carefully.
-;
-;(define (with-fatal-error-handler* handler thunk)
-;  (call-with-current-continuation
-;    (lambda (accept)
-;      (with-handler (lambda (condition more)
-;		      (if (error? condition)
-;			  (call-with-current-continuation
-;		            (lambda (decline)
-;			      (accept (handler condition decline)))))
-;		      (more))	; Keep looking for a handler.
-;        thunk))))
-
-;;; (%error-handler-cond kont eh-clauses cond-clauses)
-;;; Transform error-handler clauses into COND clauses by wrapping continuation
-;;; KONT around the body of each e-h clause, so that if it fires, the result
-;;; is thrown to KONT, but if no clause fires, the cond returns to the default
-;;; continuation.
-
-;(define-syntax %error-handler-cond
-;  (syntax-rules (=> else)
-;
-;   ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
-;    (%error-handler-cond kont
-;			 (clause ...)
-;			 ((test => (lambda (v) (kont (proc v)))) ans ...)))
-;
-;   ((%error-handler-cond kont ((test body ...) clause ...) (ans ...))
-;    (%error-handler-cond kont
-;			 (clause ...)
-;			 ((test (kont (begin body ...))) ans ...)))
-;
-;   ((%error-handler-cond kont ((else body ...)) (ans-clause ...))
-;    (cond (else body ...) ans-clause ...))
-;
-;   ((%error-handler-cond kont () (ans-clause ...))
-;    (cond ans-clause ...))))

httpd-handlers.scm

@@ -499,7 +499,9 @@
 (define (file-extension->content-type fname)
   (switch string-ci=? (file-name-extension fname)
     ((".html")		"text/html")
+    ((".txt")           "text/plain")
     ((".gif")		"image/gif")
+    ((".png")		"image/png")
     ((".jpg" ".jpeg")	"image/jpeg")
     ((".tiff" ".tif")	"image/tif")
     ((".rtf")		"text/rtf")
@@ -511,7 +513,8 @@
     ((".zip")		"application/zip")
     ((".tar")		"application/tar")
     ((".ps") 		"application/postscript")
-    (else #f)))
+    ((".pdf") 		"application/pdf")
+    (else               "application/octet-stream")))
 
 (define (file-extension->content-encoding fname)
   (cond

ls.scm

@@ -0,0 +1,290 @@
+; ls clone in scsh
+
+; Mike Sperber <sperber@informatik.uni-tuebingen.de>
+; Copyright (c) 1998 Michael Sperber.
+
+; 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 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)
+	   (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 (file-directory? path #f)
+	 (not directory?))
+    (ls-directory path all? recursive? long? directory? flag? columns? port))
+   (else
+    (ls-file path long? flag? port))))
+
+(define (ls-directory directory all? recursive? long? directory? flag? columns? port)
+  (let* ((directory (file-name-as-directory directory))
+	 (substantial-directory (string-append directory "."))
+	 (files (directory-files substantial-directory all?)))
+    (with-cwd*
+     substantial-directory
+     (lambda ()
+       (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-name)
+			 (string-append directory file-name))
+		       (filter (lambda (file)
+				 (file-directory? file #f))
+			       files))))
+	     (if (not (null? directories))
+		 (begin
+		   (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 string-length 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 ((width (display-file (car tail) flag? port)))
+		(display-spaces (- column-width width) port)
+		(vector-set! tails column (cdr tail))))))
+      (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-name long? flag? port)
+  (if long?
+      (ls-file-long file-name flag? port)
+      (ls-file-short file-name flag? port)))
+
+(define (ls-file-short file-name flag? port)
+  (display-file file-name flag? port)
+  (newline port))
+
+(define (ls-file-long file-name flag? port)
+  (let ((info (file-info file-name #f)))
+    (display-permissions info port)
+    (display-decimal-justified (file-info:nlinks info) 4 port)
+    (write-char #\space port)
+    (let ((user-name (user-info:name (user-info (file-info:uid info)))))
+      (display-padded user-name 9 port))
+    (let ((group-name (group-info:name (group-info (file-info:gid info)))))
+      (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-name flag? port)
+    (if (file-symlink? file-name)
+	(begin
+	  (display " -> " port)
+	  (display (read-symlink file-name) port)))
+    (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-name flag? port)
+  (display file-name port)
+  (if (maybe-display-flag file-name flag? port)
+      (+ 1 (string-length file-name))
+      (string-length file-name)))
+
+(define (maybe-display-flag file-name flag? port)
+  (if (not (and flag?
+		(not (file-regular? file-name))))
+      #f
+      (begin
+	(cond
+	 ((file-directory? file-name)
+	  (write-char #\/ port))
+	 ((file-symlink? file-name)
+	  (write-char #\@ port))
+	 ((file-executable? file-name)
+	  (write-char #\* port))
+	 ((file-socket? file-name)
+	  (write-char #\= port))
+	 ((file-fifo? file-name)
+	  (write-char #\| port)))
+	#t)))
+
+(define (display-permissions info port)
+  (case (file-info:type info)
+    ((directory)
+     (write-char #\d port))
+    ((symlink)
+     (write-char #\l 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))))

modules.scm

@@ -82,7 +82,8 @@
 				  string-reduce
 				  skip-whitespace
 				  string-prefix?
-				  string-suffix?)
+				  string-suffix?
+				  trim-spaces)
   (open char-set-package let-opt scheme) 
   (files stringhax))
 
@@ -152,12 +153,14 @@
 (define-structure httpd-error (export http-error?
 				      http-error
 				      fatal-syntax-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 handle-fatal-error (export with-fatal-error-handler*
+					     (with-fatal-error-handler :syntax))
+  (open scheme conditions handle)
+  (files handle-fatal-error))
 
 (define-structure httpd-core (export server/version
 				     server/protocol
@@ -238,6 +241,7 @@
 	conditions	; condition-stuff
 	defenum-package
 	httpd-error
+	handle-fatal-error
 	uri-package
 	url-package
 	formats
@@ -321,6 +325,7 @@
 	htmlout-package
 	conditions	; CONDITION-STUFF
 	url-package	; HTTP-URL record type
+	handle-fatal-error
 	scheme)
   (files httpd-handlers))
 
@@ -369,6 +374,48 @@
 	httpd-error
 	url-package
 	uri-package
+	handle-fatal-error
 	scsh
 	scheme)
   (files info-gateway))
+
+(define-structure rman-gateway (export rman-handler
+				       man
+				       parse-man-entry
+				       cat-man-page
+				       find-man-file
+				       file->man-directory
+				       cat-n-decode
+				       nroff-n-decode)
+  (open httpd-core
+	httpd-error
+	conditions
+	url-package
+	uri-package
+	htmlout-package
+	httpd-basic-handlers
+	switch-syntax
+	condhax
+	handle-fatal-error
+	scsh
+	let-opt
+	scheme)
+  (files rman-gateway))
+
+(define-structure ls (export ls
+			     arguments->ls-flags)
+  (open scheme
+	big-scheme bitwise
+	scsh)
+  (files ls))
+	
+(define-structure ftpd (export ftpd
+			       ftpd-inetd)
+  (open scheme
+	conditions handle signals
+	structure-refs
+	handle-fatal-error
+	scsh
+	crlf-io strings ls)
+  (access big-scheme)
+  (files ftpd))

rman-gateway.scm

@@ -0,0 +1,167 @@
+;;; man page -> HTML gateway for the SU web server. -*- Scheme -*-
+;;; Copyright (c) 1996 by Mike Sperber.
+;;; 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 '(rman -fHTML))
+(define rman/man '(man))
+(define rman/nroff '(nroff -man))
+(define rman/gzcat '(zcat))
+(define rman/zcat '(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)
+      (switch string=? (request:method req)
+	(("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))))
+
+	  (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")))
+
+	  (receive (man-path entry and-then) (parse-man-url (request:url req))
+	    (emit-man-page entry man man-path and-then reference-template))
+
+	  (with-tag #t address ()
+	    (display address))))
+	(else (http-error http-reply/method-not-allowed req))))))
+
+(define (cat-man-page key section)
+  (let ((title (if section
+		   (format #f "~a(~a) manual page" key section)
+		   (format #f "~a manual page" key))))
+    (emit-title #t title)
+    (emit-header #t 1 title)
+    (newline)
+    (with-tag #t body ()
+      (with-tag #t pre ()
+	(copy-inport->outport (current-input-port)
+			      (current-output-port))))))
+
+(define (emit-man-page entry man man-path and-then reference-template)
+  (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)))))
+	    (else
+	     (run (| (begin (man section key man-path))
+		     (,@rman/rman ,@and-then
+				  -r ,(reference-template entry section))))))))
+
+      (if (not (zero? status))
+	  (http-error http-reply/internal-error #f
+		      "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" . ,(join-strings man-path ":")))
+	        (run (,@rman/man ,@(if section `(,section) '()) ,key)
+		     (< /dev/null)
+		     (> 2 /dev/null)))))
+	(http-error http-reply/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)))
+     ((string=? ".Z" ext) (run (,@rman/zcat ,file)))
+     (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))))))))
+      (http-error http-reply/not-found #f "man page not found")))

stringhax.scm

@@ -1,5 +1,6 @@
 ;;; Random string-hacking procs -*- Scheme -*-
 ;;; Copyright (c) 1995 by Olin Shivers.
+;;; Copyright (c) 1997 by Mike Sperber
 
 (define (string-map f s)
   (let* ((slen (string-length s))
@@ -61,3 +62,28 @@
 (define skip-whitespace
   (let ((non-whitespace (char-set-invert char-set:whitespace)))
     (lambda (s) (char-set-index s non-whitespace))))
+
+; Why is this so complicated?
+
+(define (trim-spaces string)
+  (if (string=? "" string)
+      string
+      (let* ((length (string-length string))
+	     (start
+	      (if (not (char=? #\space (string-ref string 0)))
+		  0
+		  (do ((index 0 (+ 1 index)))
+		      ((or (= index length)
+			   (not (char=? #\space (string-ref string index))))
+		       index))))
+	     (end
+	      (if (not (char=? #\space (string-ref string (- length 1))))
+		  length
+		  (do ((index (- length 1) (- index 1)))
+		      ((or (= index 0)
+			   (not (char=? #\space (string-ref string index))))
+		       (+ 1 index))))))
+	(if (and (= 0 start)
+		 (= length end))
+	    string
+	    (substring string start end)))))