* let ftpd generate more useful output on error conditions

* include format-net package in ftpd package

format-net.scm

@@ -9,15 +9,15 @@
 
 (define (format-internet-host-address address . maybe-separator)
 
-  (define (extract shift)
-    (number->string
-     (bitwise-and (arithmetic-shift address (- shift))
-		  255)))
+  (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))))
+    (let-optionals maybe-separator ((separator "."))
+		   (string-append
+		    (extract 24) separator (extract 16) separator
+		    (extract 8) separator (extract 0)))))
   
 ;; does pretty-print of ports
 ;; Example:

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

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