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

@@ -80,16 +80,16 @@
 			     (socket:outport socket))
 	  (call-with-current-continuation
 	   (lambda (exit)
-	   (with-errno-handler*
+	     (with-errno-handler*
-	    (lambda (errno packet)
+	      (lambda (errno packet)
-	      (cond
+		(cond
-	       ;; I dunno why SHUTDOWN-SOCKET can die this way, but it
+		 ;; I dunno why SHUTDOWN-SOCKET can die this way, but it
-	       ;; can and does
+		 ;; can and does
-	       ((= errno errno/notconn)
+		 ((= errno errno/notconn)
-		(exit 'fick-dich-ins-knie))))
+		  (exit 'fick-dich-ins-knie))))
-	    (lambda ()
+	      (lambda ()
-	      (shutdown-socket socket shutdown/sends+receives)
+		(shutdown-socket socket shutdown/sends+receives)))))
-	      (close-socket socket))))))))
+	  (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
+  (call-with-current-continuation
-   (lambda (condition more)
+   (lambda (exit)
-     ;; this in really only for ftpd-quit
+     (with-handler
-     (write-replies)
+      (lambda (condition more)
-     (more))
+	(if (ftpd-quit? condition)
-   (lambda ()
+	    (with-handler
-     (let loop ()
+	     (lambda (condition ignore)
-       (write-replies)
+	       (more))
-       (accept-command)
+	     (lambda ()
-       (loop)))))
+	       (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,13 +505,15 @@
 (define (this-host-address)
   (car (host-info:addresses (host-info (system-name)))))
 
-(define (format-internet-host-address address . maybe-separator)
+(define (format-internet-host-address address)
-  (let ((separator (optional maybe-separator ".")))
+
-    (apply (lambda (b1 b2 b3 b4)
+  (define (extract shift)
-	     (string-append
+    (number->string
-	      b1 separator b2 separator
+     (bitwise-and (arithmetic-shift address (- shift))
-	      b3 separator b4))
+		  255)))
-	   (map number->string (internet-host-address-to-bytes address)))))
+
+  (string-append
+   (extract 24) "." (extract 16) "." (extract 8) "." (extract 0)))
 
 (define (format-port port)
   (string-append
@@ -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*)))