sync with WSI branch

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)

cgi-server.scm

@@ -99,7 +99,7 @@
 	       (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.
+	       (argv (if (and search (not (string-index search #\=)))	; argv list.
 		         (split-and-decode-search-spec search)
 		         '()))
 
@@ -125,7 +125,7 @@
 
 (define (split-and-decode-search-spec s)
   (let recur ((i 0))
-    (? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
+    (? ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
 					     (recur (+ j 1)))))
        (else (list (unescape-uri s i (string-length s)))))))
 
@@ -182,7 +182,7 @@
 	  ("SCRIPT_NAME"     . ,script-name)
 
 	  ("REMOTE_HOST"  . ,(host-info:name (host-info raddr)))
-	  ("REMOTE_ADDR"  . ,(internet-address->dotted-string rhost))
+	  ("REMOTE_ADDR"  . ,(internet-host-address->dotted-string rhost))
 
 	  ;; ("AUTH_TYPE" . xx)			; Random authentication
 	  ;; ("REMOTE_USER" . xx)		; features I don't understand.
@@ -265,15 +265,3 @@
       (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))))

crlf-io.scm

@@ -36,4 +36,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)))))))
+		 
+		 

ftpd.scm

@@ -0,0 +1,829 @@
+; 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-record session
+  control-input-port
+  control-output-port
+  (logged-in? #f)
+  (authenticated? #f)
+  (anonymous? #f)
+  (root-directory #f)
+  (current-directory "")
+  (to-be-renamed #f)
+  (reverse-replies '())
+  (reply-code #f) ; the last one wins
+  (type 'ascii)       ; PLEASE set this to bin 
+  (data-socket #f)
+  (passive-socket #f))
+
+(define session (make-fluid #f))
+
+(define (make-fluid-selector selector)
+  (lambda () (selector (fluid session))))
+
+(define (make-fluid-setter setter)
+  (lambda (value)
+    (setter (fluid session) value)))
+
+	
+(define session-control-input-port (make-fluid-selector session:control-input-port))
+(define session-control-output-port (make-fluid-selector session:control-output-port))
+(define session-logged-in? (make-fluid-selector session:logged-in?))
+(define session-authenticated? (make-fluid-selector session:authenticated?))
+(define session-anonymous? (make-fluid-selector session:anonymous?))
+(define session-root-directory (make-fluid-selector session:root-directory))
+(define session-current-directory (make-fluid-selector session:current-directory))
+(define session-to-be-renamed (make-fluid-selector session:to-be-renamed))
+(define session-reverse-replies (make-fluid-selector session:reverse-replies))
+(define session-reply-code (make-fluid-selector session:reply-code))
+(define session-type (make-fluid-selector session:type))
+(define session-data-socket (make-fluid-selector session:data-socket)) 
+(define session-passive-socket (make-fluid-selector session:passive-socket))
+
+(define set-session-control-input-port 
+  (make-fluid-setter set-session:control-input-port))
+(define set-session-control-output-port 
+  (make-fluid-setter set-session:control-output-port))
+(define set-session-logged-in? (make-fluid-setter set-session:logged-in?))
+(define set-session-authenticated? (make-fluid-setter set-session:authenticated?))
+(define set-session-anonymous? (make-fluid-setter set-session:anonymous?))
+(define set-session-root-directory (make-fluid-setter set-session:root-directory))
+(define set-session-current-directory (make-fluid-setter set-session:current-directory))
+(define set-session-to-be-renamed (make-fluid-setter set-session:to-be-renamed))
+(define set-session-reverse-replies (make-fluid-setter set-session:reverse-replies))
+(define set-session-reply-code (make-fluid-setter set-session:reply-code))
+(define set-session-type (make-fluid-setter set-session:type))
+(define set-session-data-socket (make-fluid-setter set-session:data-socket)) 
+(define set-session-passive-socket (make-fluid-setter set-session:passive-socket))
+	
+(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)
+       
+       (spawn
+	(lambda () 
+	  (handle-connection (socket:inport socket) 
+			     (socket:outport socket))
+	  (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))
+
+
+(define (handle-connection input-port output-port)
+  (call-with-current-continuation
+   (lambda (escape)
+     (with-handler
+      (lambda (condition more)
+	(display condition (current-error-port))
+	(escape 'fick-dich-ins-knie))
+      (lambda ()
+	(let-fluid session (make-session input-port output-port)
+		   (lambda ()
+		     (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-timeout (session-control-input-port)
+					      #f
+					      90000     ; timeout
+					      500)))    ; max interval
+    ;; (format #t "Command line: ~A~%" command-line)
+     (cond ((eq? command-line 'timeout)
+	    (register-reply! 
+	     421
+	     "Timeout (900 seconds): closing control connection.")
+	    (signal 'ftpd-quit))
+	   (else
+	    (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 (handle-user name)
+  (cond
+   ((session-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 "gasbichl")))
+
+    (set-gid (user-info:gid ftp-info))
+    (set-uid (user-info:uid ftp-info))
+
+    (set-session-logged-in? #t)
+    (set-session-authenticated? #t)
+    (set-session-anonymous? #t)
+    (set-session-root-directory (file-name-as-directory (user-info:home-dir ftp-info)))
+    (set-session-current-directory "")
+
+    (register-reply! 230 "Anonymous user logged in.")))
+
+(define (handle-pass password)
+  (cond
+   ((not (session-logged-in?))
+    (register-reply! 530 "You have not logged in yet."))
+   ((session-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 (session-root-directory) current-directory))
+	(lambda ()			; I hate gratuitous syntax
+	  (set-session-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\"."
+			   (session-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 (session-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 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-session-to-be-renamed full-path))))
+
+(define (handle-rnto path)
+  (ensure-authenticated-login)
+  (if (not (session-to-be-renamed))
+      (signal-error! 503 "Need RNFR before RNTO."))
+  (if (string=? "" path)
+      (signal-error! 500 "No argument."))
+  (let ((full-path (string-append (session-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 full-path)
+       (register-reply! 250 "File renamed.")
+       (set-session-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 (handle-type arg)
+  (cond
+   ((string-ci=? "A" arg)
+    (set-session-type 'ascii))
+   ((string-ci=? "I" arg)
+    (set-session-type 'image))
+   ((string-ci=? "L8" arg)
+    (set-session-type 'image))
+   (else
+    (signal-error! 504
+		   (format #f "Unknown TYPE: ~A." arg))))
+
+  (register-reply! 200
+		   (format #f "TYPE is now ~A."
+			   (case (session-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 (internet-host-address-from-bytes a1 a2 a3 a4)
+		      (+ (arithmetic-shift p1 8)
+			 p2)))
+	    components))))
+   (else
+    (signal-error! 500
+		   "Syntax error in argument to PORT."))))
+
+
+(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-session-data-socket socket)
+
+       (register-reply! 200
+			(format #f "Connected to ~A, port ~A."
+				(format-internet-host-address address)
+				port))))))
+
+
+(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-session-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)
+  (let ((separator (optional maybe-separator ".")))
+    (apply (lambda (b1 b2 b3 b4)
+	     (string-append
+	      b1 separator b2 separator
+	      b3 separator b4))
+	   (map number->string (internet-host-address-to-bytes address)))))
+    
+(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 (session-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 
+				   (session-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 (session-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 (session-type)
+		  ((image)
+		   (copy-port->port-binary
+		    file-port
+		    (socket:outport (session-data-socket))))
+		  ((ascii)
+		   (copy-port->port-ascii
+		    file-port
+		    (socket:outport (session-data-socket))))))))))))))
+
+(define (handle-stor path)
+  (ensure-authenticated-login)
+  (let ((full-path (string-append (session-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 (session-type)
+		((image)
+		 (copy-port->port-binary
+		  (socket:inport (session-data-socket))
+		  file-port))
+		((ascii)
+		 (copy-ascii-port->port
+		  (socket:inport (session-data-socket))
+		  file-port)))))))))))
+  
+(define (assemble-path path)
+  (let* ((interim-path
+	  (if (not (file-name-rooted? path))
+	      (string-append (file-name-as-directory 
+			      (session-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 (session-logged-in?))
+	  (not (session-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 (session-data-socket)) 
+	   (not (session-passive-socket)))
+      (signal-error! 425 "No data connection."))
+
+  (if (session-passive-socket)
+      (call-with-values
+       (lambda () (accept-connection (session-passive-socket)))
+       (lambda (socket socket-address)
+	 (set-session-data-socket socket))))
+
+  (register-reply! 150 "Opening data connection.")
+  (write-replies)
+
+  (set-socket-option (session-data-socket) level/socket
+		     socket/send-buffer *window-size*)
+  (set-socket-option (session-data-socket) level/socket
+		     socket/receive-buffer *window-size*))
+
+(define (maybe-close-data-connection)
+  (if (or (session-data-socket) (session-passive-socket))
+      (close-data-connection)))
+
+(define (close-data-connection)
+  (if (session-data-socket)
+      (close-socket (session-data-socket)))
+  (if (session-passive-socket)
+      (close-socket (session-passive-socket)))
+  (register-reply! 226 "Closing data connection.")
+  (set-session-data-socket #f)
+  (set-session-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 (string-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 (write-replies)
+  (if (not (null? (session-reverse-replies)))
+      (let loop ((messages (reverse (session-reverse-replies))))
+	(if (null? (cdr messages))
+	    (write-final-reply (car messages))
+	    (begin
+	      (write-nonfinal-reply (car messages))
+	      (loop (cdr messages))))))
+  (set-session-reverse-replies '()))
+
+(define (write-final-reply line)
+  (format (session-control-output-port) "~D ~A" (session-reply-code) line)
+  ;; (format #t "Reply: ~D ~A~%" (session-reply-code) line)
+  (write-crlf (session-control-output-port)))
+
+(define (write-nonfinal-reply line)
+  (format (session-control-output-port) "~D-~A" (session-reply-code) line)
+  ;; (format #t "Reply: ~D-~A~%" (session-reply-code) line)
+  (write-crlf (session-control-output-port)))
+
+(define (signal-error! code message)
+  (register-reply! code message)
+  (signal 'ftpd-error))
+
+(define (register-reply! code message)
+  (set-session-reverse-replies
+	(cons message (session-reverse-replies)))
+  (set-session-reply-code code))
+
+; Version
+
+(define *ftpd-version* "$Revision: 1.1.2.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
+				 #f
+				 90000    ; timeout
+				 500))    ; max interval
+	   (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 ...))))

htmlout.scm

@@ -120,6 +120,7 @@
   (apply emit-tag out tag attrs)
   (call-with-values thunk
     (lambda results
+      (newline out)
       (emit-close-tag out tag)
       (apply values results))))
 

httpd-access-control.scm

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

httpd-core.scm

@@ -50,11 +50,13 @@
 
 
 (define *http-log?* #t)
-(define *http-log-port* (error-output-port))
+(define *http-log-port* (open-output-file "/tmp/bla"))
 (define (http-log fmt . args)
-  (? (*http-log?*
-      (apply format *http-log-port* fmt args)
-      (force-output *http-log-port*))))
+  (if *http-log?*
+      (begin 
+	(apply format *http-log-port* fmt args)
+	(force-output *http-log-port*)
+	)))
 
 
 ;;; (httpd path-handler [port server-root-dir])
@@ -74,21 +76,18 @@
 	;; 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.
+	  (set-port-buffering (socket:outport sock) 'bufpol/none) ; No buffering
 
+	 (spawn (lambda ()	; Kill this line to bag forking.
+					; Should propagate. ecch.
+		  (with-current-input-port 
+		   (socket:inport  sock)		    ; bind the
+		   (with-current-output-port 
+		    (socket:outport sock)	    ; stdio ports, &
+		    (set-port-buffering (current-input-port) 'bufpol/none)
+		    (process-toplevel-request path-handler sock)
+		    (close-socket sock))) ; do it.
+		  )))
 	port))))
 
 ;;; Top-level http request processor
@@ -141,6 +140,15 @@
   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)
@@ -249,9 +257,9 @@
 
 (define (string->words s)
   (let recur ((start 0))
-    (? ((char-set-index s non-whitespace start) =>
+    (cond ((char-set-index s non-whitespace start) =>
         (lambda (start)
-	  (? ((char-set-index s char-set:whitespace start) => 
+	  (cond ((char-set-index s char-set:whitespace start) => 
 	      (lambda (end)
 		(cons (substring s start end)
 		      (recur end))))
@@ -351,6 +359,8 @@
 		   (apply really-send-http-error-reply reply-code req args))))
 
 (define (really-send-http-error-reply reply-code req . args)
+  (http-log "sending error-reply ~a ~%" reply-code)
+
   (let* ((message (if (pair? args) (car args)))
 	 (extras  (if (pair? args) (cdr args) '()))
 
@@ -367,7 +377,7 @@
 				      (reply-code->text reply-code)
 				      new-protocol?)))
 
-	 (do-msg (lambda () (? (message (display message out) (newline out))))))
+	 (do-msg (lambda () (cond (message (display message out) (newline out))))))
 
     (if new-protocol? (begin-http-header out reply-code))
 
@@ -423,7 +433,7 @@
 	 (if message (format out "<P>~%~a~%" message))))
 
       ((http-reply/internal-error)
-       (format (error-output-port) "ERROR: ~A~%" message)
+       (format (current-error-port) "ERROR: ~A~%" message)
        (when html-ok? 
          (generic-title)
 	 (format out "The server encountered an internal error or
@@ -444,10 +454,12 @@ the requested method (~A).~%"
 
       (else (if html-ok? (generic-title))))
 
-    (? (html-ok?
+    (cond (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)  ;;; TODO check this
+   ; (flush-all-ports)
     (force-output out)
 ;   (if bkp? (breakpoint "http error"))
     ))

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

@@ -55,7 +55,7 @@
 
 (define (alist-path-dispatcher handler-alist default-handler)
   (lambda (path req)
-    (? ((and (pair? path) (assoc (car path) handler-alist)) =>
+    (cond ((and (pair? path) (assoc (car path) handler-alist)) =>
         (lambda (entry) ((cdr entry) (cdr path) req)))
        (else (default-handler path req)))))
 
@@ -175,11 +175,11 @@
       (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.")))))
+      (cond ((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.
@@ -309,14 +309,14 @@
 	  => (lambda (open-match)
 	       (cond
 		((regexp-exec title-close-tag-regexp stuff
-			      (match:end open-match))
+			      (match:end open-match 0))
 		 => (lambda (close-match)
 		      (string-cut (substring stuff
-					     (match:end open-match)
-					     (match:start close-match))
+					     (match:end open-match 0)
+					     (match:start close-match 0))
 				  n)))
 		(else (string-cut (substring stuff
-					     (match:end open-match)
+					     (match:end open-match 0)
 					     (string-length stuff))
 				  n)))))
 	 (else ""))))))
@@ -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

@@ -34,11 +34,13 @@
 
 
 (define-structure crlf-io (export read-crlf-line
+				  read-crlf-line-timeout
 				  write-crlf)
   (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 crlf-io))
 
@@ -64,6 +66,7 @@
   (open receiving	; MV return (RECEIVE and VALUES)
 	condhax		; ? for COND
 	scsh-utilities	; index
+	string-lib
 	let-opt         ; let-optionals
 	strings		; lowercase-string uppercase-string
 	crlf-io		; read-crlf-line
@@ -82,7 +85,8 @@
 				  string-reduce
 				  skip-whitespace
 				  string-prefix?
-				  string-suffix?)
+				  string-suffix?
+				  trim-spaces)
   (open char-set-package let-opt scheme) 
   (files stringhax))
 
@@ -95,6 +99,7 @@
 				      uri-path-list->path
 				      simplify-uri-path)
   (open scsh-utilities
+	string-lib
 	let-opt
 	receiving
 	condhax
@@ -141,6 +146,7 @@
   (open defrec-package
 	receiving
 	condhax
+	string-lib
 	char-set-package
 	uri-package
 	scsh-utilities
@@ -152,12 +158,14 @@
 (define-structure httpd-error (export http-error?
 				      http-error
 				      fatal-syntax-error?
-				      fatal-syntax-error
-				      with-fatal-error-handler*
-				      (with-fatal-error-handler :syntax))
+				      fatal-syntax-error)
   (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
@@ -224,7 +232,8 @@
 
 				     set-my-fqdn!
 				     set-my-port!)
-  (open scsh
+  (open threads
+	scsh
 	receiving
 	let-opt
 	crlf-io
@@ -234,10 +243,12 @@
 	strings
 	char-set-package
 	defrec-package
+	define-record-types
 	handle
 	conditions	; condition-stuff
 	defenum-package
 	httpd-error
+	handle-fatal-error
 	uri-package
 	url-package
 	formats
@@ -247,7 +258,7 @@
 
 ;;; For parsing submissions from HTML forms.
 (define-structure parse-html-forms (export parse-html-form-query unescape-uri+)
-  (open scsh scsh-utilities let-opt
+  (open scsh scsh-utilities let-opt string-lib
 	receiving uri-package strings condhax scheme)
   (files parse-forms))
 
@@ -266,6 +277,7 @@
 					     cgi-handler
 					     initialise-request-invariant-cgi-env)
   (open strings
+	string-lib
 	rfc822
 	crlf-io			; WRITE-CRLF
 	uri-package
@@ -360,6 +372,7 @@
 				       find-info-file
 				       info-gateway-error)
   (open big-scheme
+	string-lib
 	conditions signals handle
 	switch-syntax
 	condhax
@@ -372,3 +385,48 @@
 	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
+	threads
+	fluids
+	string-lib
+	defrec-package
+	crlf-io strings ls)
+  (access big-scheme)
+  (files ftpd))

parse-forms.scm

@@ -4,7 +4,7 @@
 ;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html
 
 ;;; Imports and non-R4RS'isms
-;;;	index			(scsh)
+;;;	string-index		(string srfi)
 ;;;	let-optionals		(let-opt package)
 ;;;	receive			(Multiple-value return)
 ;;;     unescape-uri
@@ -45,12 +45,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.
 
 

rfc822.scm

@@ -105,7 +105,7 @@
 
 	(values #f #f)	; Blank line or EOF terminates header text.
 
-	(? ((index line1 #\:) =>	; Find the colon and
+	(? ((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.

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)))))

uri.scm

@@ -50,7 +50,11 @@
 ;;; Returns four values: scheme, path, search, frag-id.
 ;;; Each value is either #f or a string.
 
-(define uri-reserved (string->char-set "=;/#?: "))
+
+;;; MG: I think including = here will break up things, since it may be
+;;; part of the search string, preventing the ? to be found (+ and &
+;;; are excluded anyway).
+(define uri-reserved (string->char-set ";/#?: "))
 
 (define (parse-uri s)
   (let* ((slen (string-length s))
@@ -68,7 +72,6 @@
 	 (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)))
@@ -231,7 +234,7 @@
 (define (split-uri-path uri start end)		; Split at /'s (infix grammar).
   (let split ((i start))			; "" -> ("")
     (? ((>= i end) '(""))
-       ((index uri #\/ i) =>
+       ((string-index uri #\/ i) =>
 	(lambda (slash)
 	  (cons (substring uri i slash)
 		(split (+ slash 1)))))