From b99348651ded557c5ee2bdff3cb053a1eff5771f Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Wed, 20 Jun 2001 09:02:22 +0000
Subject: [PATCH] Handle quit more correctly:

Previously, it tried to write a final reply even into a socket which
had been shut down from the other end.  This would terminate the
connection thread and prevent a regular close.

So we introduce an IRREGULAR-QUIT condition for this purpose and guard against EOF better.

Also, revert to not using INTERNET-HOST-ADDRESS-TO-BYTES.
---
 ftpd.scm | 72 +++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 42 insertions(+), 30 deletions(-)

diff --git a/ftpd.scm b/ftpd.scm
index 328f24f..0d308b3 100644
--- a/ftpd.scm
+++ b/ftpd.scm
@@ -80,16 +80,16 @@
 			     (socket:outport socket))
 	  (call-with-current-continuation
 	   (lambda (exit)
-	   (with-errno-handler*
-	    (lambda (errno packet)
-	      (cond
-	       ;; I dunno why SHUTDOWN-SOCKET can die this way, but it
-	       ;; can and does
-	       ((= errno errno/notconn)
-		(exit 'fick-dich-ins-knie))))
-	    (lambda ()
-	      (shutdown-socket socket shutdown/sends+receives)
-	      (close-socket socket))))))))
+	     (with-errno-handler*
+	      (lambda (errno packet)
+		(cond
+		 ;; I dunno why SHUTDOWN-SOCKET can die this way, but it
+		 ;; can and does
+		 ((= errno errno/notconn)
+		  (exit 'fick-dich-ins-knie))))
+	      (lambda ()
+		(shutdown-socket socket shutdown/sends+receives)))))
+	  (close-socket socket))))
      
      port)))
 
@@ -128,21 +128,31 @@
 (define-condition-type 'ftpd-quit '())
 (define ftpd-quit? (condition-predicate 'ftpd-quit))
 
+(define-condition-type 'ftpd-irregular-quit '())
+(define ftpd-irregular-quit? (condition-predicate 'ftpd-irregular-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)))))
+  (call-with-current-continuation
+   (lambda (exit)
+     (with-handler
+      (lambda (condition more)
+	(if (ftpd-quit? condition)
+	    (with-handler
+	     (lambda (condition ignore)
+	       (more))
+	     (lambda ()
+	       (write-replies)
+	       (exit 'fick-dich-ins-knie)))
+	    (more)))
+      (lambda ()
+	(let loop ()
+	  (write-replies)
+	  (accept-command)
+	  (loop)))))))
 
 (define (accept-command)
   (let ((command-line (read-crlf-line-timeout (session-control-input-port)
@@ -495,14 +505,16 @@
 (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-internet-host-address address)
+
+  (define (extract shift)
+    (number->string
+     (bitwise-and (arithmetic-shift address (- shift))
+		  255)))
+
+  (string-append
+   (extract 24) "." (extract 16) "." (extract 8) "." (extract 0)))
+
 (define (format-port port)
   (string-append
    (number->string (bitwise-and (arithmetic-shift port -8) 255))
@@ -715,7 +727,7 @@
 
 (define (parse-command-line line)
   (if (eof-object? line) ; Netscape does this
-      (values "QUIT" "")
+      (signal 'ftpd-irregular-quit)
       (let* ((line (trim-spaces line))
 	     (split-position (string-index line #\space)))
 	(if split-position
@@ -795,7 +807,7 @@
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.8 $")
+(define *ftpd-version* "$Revision: 1.9 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))