added more syslog messages

ftpd.scm

@@ -69,11 +69,14 @@
 (define set-session-data-socket (make-fluid-setter set-session:data-socket)) 
 (define set-session-passive-socket (make-fluid-setter set-session:passive-socket))
 
-(define log
-  (lambda (level format-message . args)
-    (syslog level 
-	    (apply format #f format-message args))))
 
+;;; LOG -------------------------------------------------------
+(define (log level format-message . args)
+    (syslog level 
+	    (apply format #f (string-append "(thread ~D) " format-message) 
+		   (thread-uid (current-thread)) args)))
+
+;;; CONVERTERS ------------------------------------------------	    
 (define (protocol-family->string protocol-family)
   (cond ((= protocol-family protocol-family/unspecified)
 	 "unspecified")
@@ -84,13 +87,14 @@
 	(else "unknown")))
 
 (define (socket->string socket)
-  (format #f "family: ~A, local address: ~A, remote address: ~A, input-port ~A, output-port ~A"
+  (format #f "family: ~A, ~&local address: ~A, ~&remote address: ~A, ~&input-port ~A, ~&output-port ~A"
 	  (protocol-family->string (socket:family socket))
 	  (socket-address->string (socket-local-address socket))
 	  (socket-address->string (socket-remote-address socket))
 	  (socket:inport socket)
 	  (socket:outport socket)))
 
+
 (define (socket-address->string socket-address)
   (call-with-values
    (lambda () (socket-address->internet-address socket-address))
@@ -99,6 +103,8 @@
 	     (format-internet-host-address host-address)
 	     (format-port service-port)))))
 
+;;; ftpd  -------------------------------------------------------
+
 (define (ftpd anonymous-home . maybe-port)
   (let ((port (optional maybe-port 21)))
     (with-syslog-destination 
@@ -141,9 +147,6 @@
 		    ((= errno errno/notconn)
 		     (log (syslog-level warning) 
 			  "socket not connected any more - exiting thread")
-		     (log (syslog-level debug) 
-			  "socket ~S not connected any more"
-			  (socket->string socket))
 		     (exit 'fick-dich-ins-knie))))
 		 (lambda ()
 		   (log (syslog-level debug)
@@ -186,10 +189,18 @@
 
 
 (define (handle-connection input-port output-port anonymous-home)
+  (log (syslog-level debug)
+       "handling connection with input-port ~A, outputport ~A and home ~A"
+       input-port
+       output-port
+       anonymous-home)
   (call-with-current-continuation
    (lambda (escape)
      (with-handler
       (lambda (condition more)
+	(log (syslog-level debug)
+	     "hit error condition ~A -- exiting"
+	     (condition-type condition))
 	(display condition (current-error-port))
 	(escape 'fick-dich-ins-knie))
       (lambda ()
@@ -200,6 +211,8 @@
 		     (handle-commands))))))))
 
 (define (display-banner)
+  (log (syslog-level debug)
+       "displaying banner")
   (register-reply! 220
 		   (string-append
 		    "Scheme Untergrund ftp server ("
@@ -217,35 +230,47 @@
 
 
 (define (handle-commands)
+  (log (syslog-level debug) "handling commands")
   (call-with-current-continuation
    (lambda (exit)
      (with-handler
       (lambda (condition more)
 	(if (ftpd-quit? condition)
-	    (with-handler
+	    (begin
-	     (lambda (condition ignore)
+	      (log (syslog-level debug) "quitting")
-	       (more))
+	      (with-handler
-	     (lambda ()
+	       (lambda (condition ignore)
-	       (write-replies)
+		 (more))
-	       (exit 'fick-dich-ins-knie)))
+	       (lambda ()
+		 (write-replies)
+		 (exit 'fick-dich-ins-knie))))
 	    (more)))
       (lambda ()
+	(log (syslog-level debug)
+	     "starting write-accept-loop")
 	(let loop ()
 	  (write-replies)
 	  (accept-command)
 	  (loop)))))))
 
 (define (accept-command)
-  (let ((command-line (read-crlf-line-timeout (session-control-input-port)
+  (let* ((timeout-seconds 90)
-					      #f
+	 (command-line (read-crlf-line-timeout (session-control-input-port)
-					      90000     ; timeout
+					       #f
-					      500)))    ; max interval
+					       (* 1000 timeout-seconds);timeout
-    ;; (format #t "Command line: ~A~%" command-line)
+					       500)))    ; max interval
-     (cond ((eq? command-line 'timeout)
+    (log (syslog-level debug) 
-	    (register-reply! 
+	 "Command line: ~A" 
-	     421
+	 command-line)
-	     "Timeout (900 seconds): closing control connection.")
+    (cond ((eq? command-line 'timeout)
-	    (signal 'ftpd-quit))
+	   (log (syslog-level debug)
+		"hit timelimit (~D seconds) -- closing control connection."
+		timeout-seconds)
+	   (register-reply! 
+	    421
+	    (format #f "Timeout (~D seconds): closing control connection."
+		    timeout-seconds)
+	    (signal 'ftpd-quit)))
 	   (else
 	    (call-with-values
 	     (lambda () (parse-command-line command-line))
@@ -253,23 +278,35 @@
 	       (handle-command command arg)))))))
 
 (define (handle-command command arg)
+  (log (syslog-level debug)
+       "handling command ~S with argument ~S"
+       command arg)
   (call-with-current-continuation
    (lambda (escape)
      (with-handler
       (lambda (condition more)
 	(cond
 	 ((error? condition)
+	  (log (syslog-level notice)
+	       "internal error occured: ~S -- replying (451) and escaping"
+	       condition)
 	  (register-reply! 451
 			   (format #f "Internal error: ~S"
 				   (condition-stuff condition)))
 	  (escape 'fick-dich-ins-knie))
 	 ((ftpd-error? condition)
+	  (log (syslog-level notice)
+	       "ftpd error occured: ~S -- escaping"  ; this may occur more often than you think (??)
+	       (condition-stuff condition))
 	  (escape 'fick-dich-ins-knie))
 	 (else
 	  (more))))
       (lambda ()
 	(with-errno-handler*
 	 (lambda (errno packet)
+	   (log (syslog-level notice)
+		"unix error occured: ~S -- replying (451) and escaping"
+		(car packet))
 	   (register-reply! 451
 			    (format #f "Unix error: ~A." (car packet)))
 	   (escape 'fick-dich-ins-knie))
@@ -277,6 +314,9 @@
 	   (dispatch-command command arg))))))))
 
 (define (dispatch-command command arg)
+  (log (syslog-level debug)
+       "dispatching command ~S with argument ~S"
+       command arg)
   (cond
    ((assoc command *command-alist*)
     => (lambda (pair)
@@ -886,7 +926,7 @@
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.18 $")
+(define *ftpd-version* "$Revision: 1.19 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))