- removed some leftover debugging output

- simplified exception handling (and probably fixed some bugs)
- banners are now lists of lines
- rewrote bogus reply output code

scheme/ftpd/ftpd.scm

@@ -2,7 +2,7 @@
 
 ;;; This file is part of the Scheme Untergrund Networking package.
 
-;;; Copyright (c) 1998-2002 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
+;;; Copyright (c) 1998-2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
@@ -34,9 +34,10 @@
 (define (make-default-ftpd-options)
   (really-make-ftpd-options 21
 			    "~ftp"
+			    (list
 			     (string-append "Scheme Untergrund ftp server (version "
 					    sunet-version-identifier
-					   ") ready.")
+					    ") ready."))
 			    #f
 			    #f))
 
@@ -86,7 +87,7 @@
 		       root-directory
 		       current-directory
 		       to-be-renamed
-		       reverse-replies
+		       replies
 		       reply-code
 		       type
 		       data-socket
@@ -110,8 +111,8 @@
 		     set-session-current-directory!)
   (to-be-renamed session-to-be-renamed
 		 set-session-to-be-renamed!)
-  (reverse-replies session-reverse-replies
+  (replies session-replies
-		   set-session-reverse-replies!)
+		   set-session-replies!)
   (reply-code session-reply-code
 	      set-session-reply-code!)
   (type session-type
@@ -132,7 +133,7 @@
 		       #f		; root-directory
 		       ""		; current-directory
 		       #f		; to-be-renamed
-		       '()		; reverse-replies
+		       '()		; replies
 		       #f		; reply-code
 		       'ascii		; type
 		       #f		; data-socket
@@ -164,7 +165,7 @@
 (define the-session-root-directory (make-session-selector session-root-directory))
 (define the-session-current-directory (make-session-selector session-current-directory))
 (define the-session-to-be-renamed (make-session-selector session-to-be-renamed))
-(define the-session-reverse-replies (make-session-selector session-reverse-replies))
+(define the-session-replies (make-session-selector session-replies))
 (define the-session-reply-code (make-session-selector session-reply-code))
 (define the-session-type (make-session-selector session-type))
 (define the-session-data-socket (make-session-selector session-data-socket)) 
@@ -187,8 +188,8 @@
   (make-session-modifier set-session-current-directory!))
 (define set-the-session-to-be-renamed!
   (make-session-modifier set-session-to-be-renamed!))
-(define set-the-session-reverse-replies!
+(define set-the-session-replies!
-  (make-session-modifier set-session-reverse-replies!))
+  (make-session-modifier set-session-replies!))
 (define set-the-session-reply-code!
   (make-session-modifier set-session-reply-code!))
 (define set-the-session-type!
@@ -330,7 +331,6 @@
 ;;; ftpd  -------------------------------------------------------
 
 (define (ftpd ftpd-options)
-  (display ">>>ftpd ") (write (list (ftpd-options-port ftpd-options))) (newline)
   (with-syslog-destination 
    "ftpd"
    #f
@@ -456,8 +456,7 @@
 (define (display-banner)
   (log (syslog-level debug)
        "displaying banner (220)")
-  (register-reply! 220
+  (apply register-reply! 220 (the-ftpd-options-banner)))
-		   (the-ftpd-options-banner)))
 
 (define-condition-type 'ftpd-quit '())
 (define ftpd-quit? (condition-predicate 'ftpd-quit))
@@ -519,12 +518,10 @@
 	       (handle-command command arg)))))))
 
 (define (handle-command command arg)
-;  (log (syslog-level debug)
+;;  (log (syslog-level debug)
-;       "handling command ~S with argument ~S"
+;;       "handling command ~S with argument ~S"
-;       command arg)
+;;       command arg)
-  (call-with-current-continuation
+  (with-fatal-error-handler*
-   (lambda (escape)
-     (with-handler
    (lambda (condition more)
      (cond
       ((error? condition)
@@ -532,15 +529,13 @@
 	 (log (syslog-level notice)
 	      "internal error occured: ~S (maybe reason: ~S) -- replying and escaping (451)"
 	      condition reason)
-	    (register-reply! 451
+	 (replace-reply! 451
-			     (format #f "Internal error: ~S" reason))
+			 (format #f "Internal error: ~S" reason))))
-	    (escape 'fick-dich-ins-knie)))
       ((ftpd-error? condition)
-          ; debug level because nearly every unsuccessful command ends
+       ;; debug level because nearly every unsuccessful command ends
-          ; here (no args, can't change dir, etc.)
+       ;; here (no args, can't change dir, etc.)
        (log (syslog-level debug)  
-	       "ftpd error occured (maybe reason: ~S)-- escaping" (condition-stuff condition))
+	    "ftpd error occured (maybe reason: ~S)-- escaping" (condition-stuff condition)))
-	  (escape 'fick-dich-ins-knie))
       (else
        (more))))
    (lambda ()
@@ -550,11 +545,10 @@
 	  (log (syslog-level notice)
 	       "unix error occured: ~S -- replying (451) and escaping"
 	       unix-error)
-	     (register-reply! 451
+	  (replace-reply! 451
-			      (format #f "Unix error: ~A." unix-error))
+			  (format #f "Unix error: ~A." unix-error))))
-	     (escape 'fick-dich-ins-knie)))
       (lambda ()
-	   (dispatch-command command arg))))))))
+	(dispatch-command command arg))))))
 
 (define (dispatch-command command arg)
 ;  (log (syslog-level debug)
@@ -1286,39 +1280,39 @@
 
 ; Reply handling
 
-; Replies must be synchronous with requests and actions.  Therefore,
+; For the nature of the replies, see RFC 959.
-; 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? (the-session-reverse-replies)))
+  (let ((replies (the-session-replies)))
-      (let loop ((messages (reverse (the-session-reverse-replies))))
+    (cond
-	(if (null? (cdr messages))
+     ((null? replies)
-	    (write-final-reply (car messages))
+      (error "no reply registered"))
-	    (begin
+     (else
-	      (write-nonfinal-reply (car messages))
+      (let loop ((replies replies))
-	      (loop (cdr messages))))))
+	(if (not (null? replies))
-  (set-the-session-reverse-replies! '()))
+	    (let ((reply-text 
-
+		   (format #f
-(define (write-final-reply line)
+			   (if (pair? (cdr replies))
-  (format (the-session-control-output-port) "~D ~A" (the-session-reply-code) line)
+			       "~D-~A"
-  (log (syslog-level debug) "Reply: ~D ~A~%" (the-session-reply-code) line)
+			       "~D ~A")
+			   (the-session-reply-code)
+			   (car replies))))
+	      (display reply-text (the-session-control-output-port))
 	      (write-crlf (the-session-control-output-port))
-  (force-output (the-session-control-output-port)))
+	      (log (syslog-level debug) "Reply: ~A" reply-text)
-
+	      (loop (cdr replies))))))))
-(define (write-nonfinal-reply line)
+  (set-the-session-reply-code! #f))
-  (format (the-session-control-output-port) "~D-~A" (the-session-reply-code) line)
-  (log (syslog-level debug) "Reply: ~D-~A~%" (the-session-reply-code) line)
-  (write-crlf (the-session-control-output-port)))
 
 (define (signal-error! code message)
-  (register-reply! code message)
+  (replace-reply! code message)
   (signal 'ftpd-error))
 
-(define (register-reply! code message)
+(define (register-reply! code . messages)
-  (set-the-session-reverse-replies!
+  (if (the-session-reply-code)
-	(cons message (the-session-reverse-replies)))
+      (apply error "tried to register more than one reply" code messages)
+      (apply replace-reply! code messages)))
+
+(define (replace-reply! code . messages)
+  (set-the-session-replies! messages)
   (set-the-session-reply-code! code))