From a76848a6c6d43cecac2027d6d7d64b92fa248bfe Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Tue, 13 Nov 2001 13:50:24 +0000
Subject: [PATCH] * let ftpd generate more useful output on error conditions *
 include format-net package in ftpd package

---
 format-net.scm | 20 ++++++++---------
 ftpd.scm       | 61 ++++++++++++++++++--------------------------------
 modules.scm    |  4 ++--
 3 files changed, 34 insertions(+), 51 deletions(-)

diff --git a/format-net.scm b/format-net.scm
index 6f25469..30f419e 100644
--- a/format-net.scm
+++ b/format-net.scm
@@ -9,16 +9,16 @@
 
 (define (format-internet-host-address address . maybe-separator)
 
-  (define (extract shift)
-    (number->string
-     (bitwise-and (arithmetic-shift address (- shift))
-		  255)))
-
-  (let-optionals maybe-separator ((separator "."))
-    (string-append
-     (extract 24) separator (extract 16) separator
-     (extract 8) separator (extract 0))))
-
+  (let ((extract (lambda (shift)
+		   (number->string
+		    (bitwise-and (arithmetic-shift address (- shift))
+				 255)))))
+		 
+    (let-optionals maybe-separator ((separator "."))
+		   (string-append
+		    (extract 24) separator (extract 16) separator
+		    (extract 8) separator (extract 0)))))
+  
 ;; does pretty-print of ports
 ;; Example:
 ;; (format-port #x0aff)
diff --git a/ftpd.scm b/ftpd.scm
index 0b32e7e..e628c41 100644
--- a/ftpd.scm
+++ b/ftpd.scm
@@ -228,8 +228,9 @@
      (with-handler
       (lambda (condition more)
 	(log (syslog-level debug)
-	     "hit error condition ~A -- exiting"
-	     (condition-type condition))
+	     "hit error condition ~A (maybe reason (maybe Netscape?): ~S) -- exiting"
+	     (condition-type condition)
+	     (condition-stuff condition))
 	(display condition (current-error-port))
 	(escape 'fick-dich-ins-knie))
       (lambda ()
@@ -317,18 +318,18 @@
       (lambda (condition more)
 	(cond
 	 ((error? condition)
-	  (log (syslog-level notice)
-	       "internal error occured: ~S -- replying and escaping (451)"
-	       condition)
-	  (register-reply! 451
-			   (format #f "Internal error: ~S"
-				   (condition-stuff condition)))
-	  (escape 'fick-dich-ins-knie))
+	  (let ((reason (condition-stuff condition)))
+	    (log (syslog-level notice)
+		 "internal error occured: ~S (maybe reason: ~S) -- replying and escaping (451)"
+		 condition reason)
+	    (register-reply! 451
+			     (format #f "Internal error: ~S" reason))
+	    (escape 'fick-dich-ins-knie)))
 	 ((ftpd-error? condition)
           ; debug level because nearly every unsuccessful command ends
           ; here (no args, can't change dir, etc.)
 	  (log (syslog-level debug)  
-	       "ftpd error occured -- escaping")
+	       "ftpd error occured (maybe reason: ~S)-- escaping" (condition-stuff condition))
 	  (escape 'fick-dich-ins-knie))
 	 (else
 	  (more))))
@@ -781,24 +782,6 @@
    (lambda (host-address control-port)
      host-address)))
 
-(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)
   (log-command (syslog-level info) "NLST" arg)
   (handle-listing arg '()))
@@ -887,11 +870,12 @@
 						 path))))
     (with-fatal-error-handler*		; CALL-WITH-INPUT-FILE doesn't go through ERRNO
      (lambda (condition more)
-       (log (syslog-level info) "failed to open ~S for reading (550)" full-path)
-       (log (syslog-level debug) "reporting about ~S" path)
-       (signal-error! 550
-		      (format #f "Can't open \"~A\" for reading."
-			      path)))
+       (let ((reason (condition-stuff condition)))
+	 (log (syslog-level info) "failed to open ~S for reading (maybe reason: ~S) (550)" full-path reason)
+	 (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason)
+	 (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)))
@@ -931,11 +915,10 @@
 						 path))))
     (with-fatal-error-handler*
      (lambda (condition more)
-       (log (syslog-level info) "can't open ~S for writing (550)" full-path)
-       (log (syslog-level debug) "replying error for file ~S" path)
-       (signal-error! 550
-		      (format #f "Can't open \"~A\" for writing."
-			      path)))
+       (let ((reason (condition-stuff condition)))
+	 (log (syslog-level info) "can't open ~S for writing (maybe reason: ~S) (550)" full-path reason)
+	 (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason)
+	 (signal-error! 550 (format #f "Can't open \"~A\" for writing." path))))
      (lambda ()
        (call-with-output-file full-path
 	 (lambda (file-port)
@@ -1144,7 +1127,7 @@
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.25 $")
+(define *ftpd-version* "$Revision: 1.26 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))
diff --git a/modules.scm b/modules.scm
index 6fbb0eb..6a01325 100644
--- a/modules.scm
+++ b/modules.scm
@@ -479,7 +479,6 @@
 	scsh)
   (files ls))
 	
-
 (define-interface ftpd-interface 
   (export ftpd
 	  ftpd-inetd))
@@ -495,7 +494,8 @@
 	string-lib
 	big-util
 	defrec-package
-	crlf-io strings ls)
+	crlf-io strings ls
+	format-net)                 ; pretty print of internet-addresses
   (access big-scheme)
   (files ftpd))