* finished adding syslogs to ftpd

* trim-spaces doesn't throw exception on emtpy strings any more
* spawn-thunk in FTPD moved to new procedure
* always catching SOCKET->STRING errors
* log-calls don't produce extra calculations anymore
* consequently logging reply codes
: ----------------------------------------------------------------------

ftpd.scm

@@ -11,6 +11,17 @@
 ; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
 
 
+; following things should be improved:
+;
+; - GET-command: ftpd reports "Can't open FILENAME for reading" if
+;   file actually doesn't exist. This is confusing. Reporting
+;   "FILENAME does not exist" is much better.
+; - logging: 
+;   * improve syslog-levels (too much debug-messages?)  
+;   * improve perfomance (values are often calculated twice: first
+;     time for logging, second time for reporting
+; BRNR: STOPPED at 836
+
 (define-record session
   control-input-port
   control-output-port
@@ -76,6 +87,16 @@
 	    (apply format #f (string-append "(thread ~D) " format-message) 
 		   (thread-uid (current-thread)) args)))
 
+(define (log-command command-name . argument)
+  (if (null? argument)
+      (log (syslog-level debug) "handling ~A-command" command-name)
+      (if (not (null? (cdr argument)))
+	  (log (syslog-level debug) "handling ~A-command with arguments ~S"
+	       command-name argument)
+	  (log (syslog-level debug) "handling ~A-command with argument ~S"
+	       command-name (car argument)))))
+
+
 ;;; CONVERTERS ------------------------------------------------	    
 (define (protocol-family->string protocol-family)
   (cond ((= protocol-family protocol-family/unspecified)
@@ -113,54 +134,67 @@
      #f
      #f
      (lambda ()
-			     
        (log (syslog-level notice) 
 	    "starting on port ~D with ~S as anonymous home"
 	    port (expand-file-name anonymous-home (cwd)))
+
        (bind-listen-accept-loop
 	protocol-family/internet
 	(lambda (socket address)
-	  
+	  (let ((remote-address (socket-address->string address)))
-	  (log (syslog-level info)
+	    (set-ftp-socket-options! socket)
-	       "new connection with ~S"
+	    (spawn
-	       (socket-address->string address))
+	     (spawn-to-handle-connection socket
-
+					 address
-	  (log (syslog-level debug)
+					 anonymous-home
-	       "got connection with socket ~S and address ~S"
+					 port
-	       (socket->string socket) 
+					 remote-address)
-	       (socket-address->string address))
+	     remote-address)))    ; use remote address as thread-name
-	  
-	  (set-ftp-socket-options! socket)
-	  
-	  (spawn
-	   (lambda () 
-	     (handle-connection (socket:inport socket) 
-				(socket:outport socket)
-				(file-name-as-directory anonymous-home))
-	     (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
-		    ((or (= errno errno/notconn)
-			 ;; this one can come out of SOCKET->STRING
-			 (= errno errno/inval))
-		     (log (syslog-level warning) 
-			  "socket not connected any more - exiting thread")
-		     (exit 'fick-dich-ins-knie))))
-		 (lambda ()
-		   (log (syslog-level debug)
-			"shutting down socket ~S"
-			(socket->string socket))
-		   (shutdown-socket socket shutdown/sends+receives)))))
-	     (log (syslog-level info)
-		  "closing socket")
-	     (close-socket socket))
-	   (socket-address->string address)))    ; use remote address as thread-name
 	port)))))
 
+(define (spawn-to-handle-connection socket address anonymous-home port remote-address)
+  (lambda ()
+    (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
+	   ((or (= errno errno/notconn)
+		;; this one can come out of SOCKET->STRING
+		(= errno errno/inval))
+	    (log (syslog-level info) 
+		 "socket to ~A not connected any more - exiting" 
+		 remote-address)
+	    (exit 'fick-dich-ins-knie))))
+	(lambda ()
+	  (let ((socket-string (socket->string socket)))
+	
+	    (log (syslog-level info)
+		 "new connection to ~S"
+		 remote-address)
+
+	    (log (syslog-level debug)
+		 "got connection with socket ~S and address ~S"
+		 socket-string
+		 remote-address)
+	    
+	    (handle-connection (socket:inport socket) 
+			       (socket:outport socket)
+			       (file-name-as-directory anonymous-home))
+
+	    (log (syslog-level debug)
+		 "shutting down socket ~S"
+		 socket-string)
+	    (shutdown-socket socket shutdown/sends+receives)
+	    
+	    (log (syslog-level info)
+		 "closing socket to ~A and finishing thread" remote-address)
+	    (log (syslog-level debug)
+		 "closing socket (~A) and finishing thread" socket-string)
+	    (close-socket socket))))))))
+
 (define (ftpd-inetd anonymous-home)
   (with-syslog-destination 
    "ftpd"
@@ -214,7 +248,7 @@
 
 (define (display-banner)
   (log (syslog-level debug)
-       "displaying banner")
+       "displaying banner (220)")
   (register-reply! 220
 		   (string-append
 		    "Scheme Untergrund ftp server ("
@@ -239,7 +273,7 @@
       (lambda (condition more)
 	(if (ftpd-quit? condition)
 	    (begin
-	      (log (syslog-level debug) "quitting")
+	      (log (syslog-level debug) "quitting (write-accept-loop)")
 	      (with-handler
 	       (lambda (condition ignore)
 		 (more))
@@ -266,7 +300,7 @@
 	 command-line)
     (cond ((eq? command-line 'timeout)
 	   (log (syslog-level debug)
-		"hit timelimit (~D seconds) -- closing control connection."
+		"hit timelimit (~D seconds) -- closing control connection and quitting (421)"
 		timeout-seconds)
 	   (register-reply! 
 	    421
@@ -280,9 +314,9 @@
 	       (handle-command command arg)))))))
 
 (define (handle-command command arg)
-  (log (syslog-level debug)
+;  (log (syslog-level debug)
-       "handling command ~S with argument ~S"
+;       "handling command ~S with argument ~S"
-       command arg)
+;       command arg)
   (call-with-current-continuation
    (lambda (escape)
      (with-handler
@@ -290,36 +324,36 @@
 	(cond
 	 ((error? condition)
 	  (log (syslog-level notice)
-	       "internal error occured: ~S -- replying (451) and escaping"
+	       "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))
 	 ((ftpd-error? condition)
-	  (log (syslog-level notice)
+	  (log (syslog-level debug)
 	       "ftpd error occured: ~S -- escaping"  
-	       ; must this occur everytime CDUP is called in ftp-root-path?
+	       condition)
-	       (condition-stuff condition))
 	  (escape 'fick-dich-ins-knie))
 	 (else
 	  (more))))
       (lambda ()
 	(with-errno-handler*
 	 (lambda (errno packet)
-	   (log (syslog-level notice)
+	   (let ((unix-error (car packet)))
-		"unix error occured: ~S -- replying (451) and escaping"
+	     (log (syslog-level notice)
-		(car packet))
+		  "unix error occured: ~S -- replying (451) and escaping"
-	   (register-reply! 451
+		  unix-error)
-			    (format #f "Unix error: ~A." (car packet)))
+	     (register-reply! 451
-	   (escape 'fick-dich-ins-knie))
+			      (format #f "Unix error: ~A." unix-error))
+	     (escape 'fick-dich-ins-knie)))
 	 (lambda ()
 	   (dispatch-command command arg))))))))
 
 (define (dispatch-command command arg)
-  (log (syslog-level debug)
+;  (log (syslog-level debug)
-       "dispatching command ~S with argument ~S"
+;       "dispatching command ~S with argument ~S"
-       command arg)
+;       command arg)
   (cond
    ((assoc command *command-alist*)
     => (lambda (pair)
@@ -339,8 +373,7 @@
 
 
 (define (handle-user name)
-  (log (syslog-level debug) "handling USER-command with name ~S"
+  (log-command "USER" name)
-       name)
   (cond
    ((session-logged-in?)
     (log (syslog-level debug) "user ~S is already logged in (230)"
@@ -366,8 +399,7 @@
   (register-reply! 230 "Anonymous user logged in."))
 
 (define (handle-pass password)
-  (log (syslog-level debug) "handling PASS-command with password ~S"
+  (log-command "PASS" password)
-       password)
   (cond
    ((not (session-logged-in?))
     (log (syslog-level debug) "Rejecting password as user is not logged in yet. (530)")
@@ -380,29 +412,31 @@
     (register-reply! 502 "This can't happen."))))
 
 (define (handle-quit foo)
-  (log (syslog-level debug) "handling QUIT-command (221)")
+  (log-command "QUIT")
+  (log (syslog-level debug) "quitting (221)")
   (register-reply! 221 "Goodbye!  Au revoir!  Auf Wiedersehen!")
   (signal 'ftpd-quit))
 
 (define (handle-syst foo)
+  (log-command "SYST")
   (log (syslog-level debug) "telling system type (215)")
   (register-reply! 215 "UNIX Type: L8"))
 
 (define (handle-cwd path)
-  (log (syslog-level debug) "handling CWD-command with ~S as path-argument"
+  (log-command "CWD" path)
-       path)
   (ensure-authenticated-login)
   (let ((current-directory (assemble-path (session-current-directory)
 					  path)))
     (with-errno-handler*
      (lambda (errno packet)
-       (log (syslog-level debug)
+       (let ((error-reason (car packet)))
-	    "can't change to directory \"~A\": ~A (550)"
+	 (log (syslog-level debug)
-	    path (car packet))
+	      "can't change to directory \"~A\": ~A (550)"
-       (signal-error! 550
+	      path error-reason)
+	 (signal-error! 550
 			(format #f "Can't change directory to \"~A\": ~A."
 				path
-				(car packet))))
+				error-reason))))
      (lambda ()
        (with-cwd*
 	(file-name-as-directory
@@ -417,32 +451,39 @@
 				   current-directory))))))))
 
 (define (handle-cdup foo)
-  (log (syslog-level debug) "handling CDUP-command as \"CWD ..\"")
+  (log-command "CDUP")
   (handle-cwd ".."))
 
 (define (handle-pwd foo)
-  (log (syslog-level debug) "handling PWD-command")
+  (log-command "PWD")
   (ensure-authenticated-login)
-  (log (syslog-level debug) "replying \"/~A\" as current directory (257)"
+  (let ((current-directory (session-current-directory)))
-       (session-current-directory))
+    (log (syslog-level debug) "replying \"/~A\" as current directory (257)"
-  (register-reply! 257
+	 current-directory)
-		   (format #f "Current directory is \"/~A\"."
+    (register-reply! 257
-			   (session-current-directory))))
+		     (format #f "Current directory is \"/~A\"."
+			     current-directory))))
 
 
 (define (make-file-action-handler error-format-string action)
   (lambda (path)
     (ensure-authenticated-login)
     (if (string=? "" path)
-	(signal-error! 500 "No argument."))
+	(begin
+	  (log (syslog-level debug) 
+	       "finishing processing command because of missing arguments (500)")
+	  (signal-error! 500 "No argument.")))
     (let ((full-path (string-append (session-root-directory)
 				    (assemble-path (session-current-directory)
 						   path))))
       (with-errno-handler*
        (lambda (errno packet)
-	 (signal-error! 550
+	 (let ((error-reason (car packet)))
-			(format #f error-format-string
+	   (log (syslog-level debug)
-				path (car packet))))
+		(string-append error-format-string " (550)") path error-reason)
+	   (signal-error! 550
+			  (format #f error-format-string
+				  path error-reason))))
        (lambda ()
 	 (action path full-path))))))
 
@@ -450,23 +491,35 @@
   (make-file-action-handler
    "Could not delete \"~A\": ~A."
    (lambda (path full-path)
+     (log-command "DELE" path)
      (delete-file full-path)
+     (log (syslog-level debug) "deleted ~S, reporting deletion of ~S (250)" 
+	  full-path path)
      (register-reply! 250 (format #f "Deleted \"~A\"." path)))))
 
 (define handle-mdtm
   (make-file-action-handler
    "Could not get info on \"~A\": ~A."
    (lambda (path full-path)
+     (log-command "MDTM" path)
      (let* ((info (file-info full-path))
-	    (the-date (date (file-info:mtime info) 0)))
+	    (the-date (date (file-info:mtime info) 0))
+	    (formatted-date (format-date "~Y~m~d~H~M~S" the-date)))
+       (log (syslog-level debug) "reporting modification time of ~S: ~A (213)"
+	    full-path
+	    formatted-date)
        (register-reply! 213
-			(format-date "~Y~m~d~H~M~S" the-date))))))
+			formatted-date)))))
 
 (define handle-mkd
   (make-file-action-handler
    "Could not make directory \"~A\": ~A."
    (lambda (path full-path)
+     (log-command "MKD" path)
      (create-directory full-path #o755)
+     (log (syslog-level debug) 
+	  "created directory ~S, reporting creation of directory ~S (257)" 
+	  full-path path)
      (register-reply! 257
 		      (format #f "Created directory \"~A\"." path)))))
 
@@ -474,7 +527,11 @@
   (make-file-action-handler
    "Could not remove directory \"~A\": ~A."
    (lambda (path full-path)
+     (log-command "RMD" path)
      (delete-directory full-path)
+     (log (syslog-level debug) 
+	  "deleted directory ~S, reporting deletion of directory ~S (250)"
+	  full-path path)
      (register-reply! 250
 		      (format #f "Deleted directory \"~A\"." path)))))
 
@@ -483,59 +540,95 @@
   (make-file-action-handler
    "Could not get info on file \"~A\": ~A."
    (lambda (path full-path)
+     (log-command "RNFR" path)
      (file-info full-path)
+     (log (syslog-level debug)
+	  "RNFR-command accepted, waiting for RNTO-command (350)")
      (register-reply! 350 "RNFR accepted.  Gimme a RNTO next.")
      (set-session-to-be-renamed full-path))))
 
 (define (handle-rnto path)
+  (log-command "RNTO" path)
   (ensure-authenticated-login)
   (if (not (session-to-be-renamed))
-      (signal-error! 503 "Need RNFR before RNTO."))
+      (begin
+	(log (syslog-level debug) 
+	     "RNTO-command rejected: need RNFR-command before (503)")
+	(signal-error! 503 "Need RNFR before RNTO.")))
   (if (string=? "" path)
-      (signal-error! 500 "No argument."))
+      (begin
+	(log (syslog-level debug)
+	     "No argument -- still waiting for (correct) RNTO-command (500)")
+	(signal-error! 500 "No argument.")))
   (let ((full-path (string-append (session-root-directory)
 				  (assemble-path (session-current-directory)
 						 path))))
 
     (if (file-exists? full-path)
-	(signal-error!
+	(begin
-	 550
+	  (log (syslog-level debug)
-	 (format #f "Rename failed---\"~A\" already exists or is protected."
+	       "rename of ~S failed (already exists), reporting failure of renaming ~S (550)"
-		 path)))
+	       full-path path)
+	  (signal-error!
+	   550
+	   (format #f "Rename failed---\"~A\" already exists or is protected."
+		   path))))
 
     (with-errno-handler*
      (lambda (errno packet)
+       (log (syslog-level debug)
+	    "failed to rename ~A (550)" path)
        (signal-error! 550
 		      (format #f "Could not rename: ~A." path)))
      (lambda ()
-       (rename-file (session-to-be-renamed) full-path)
+       (let ((old-name (session-to-be-renamed)))
-       (register-reply! 250 "File renamed.")
+	 (rename-file old-name full-path)
-       (set-session-to-be-renamed #f)))))
+	 (log (syslog-level debug)
+	      "~S renamed to ~S - no more waiting for RNTO-command (250)"
+	      old-name full-path)
+	 (register-reply! 250 "File renamed.")
+	 (set-session-to-be-renamed #f))))))
   
 (define handle-size
   (make-file-action-handler
    "Could not get info on file \"~A\": ~A."
    (lambda (path full-path)
+     (log-command "SIZE" path)
      (let ((info (file-info full-path)))
        (if (not (eq? 'regular (file-info:type info)))
-	   (signal-error! 550
+	   (begin
-			  (format #f "\"~A\" is not a regular file."
+	     (log (syslog-level debug)
-				  path)))
+		  "rejecting SIZE-command as ~S is not a regular file, reporting on ~S (550)"
-       (register-reply! 213 (number->string (file-info:size info)))))))
+		  full-path path)
+	     (signal-error! 550
+			    (format #f "\"~A\" is not a regular file."
+				    path))))
+       (let ((file-size (file-info:size info)))
+	 (log (syslog-level debug)
+	      "reporting ~D as size of ~S (213)"
+	      file-size full-path)
+	 (register-reply! 213 (number->string file-size)))))))
 
 
 (define (handle-type arg)
+  (log-command "TYPE" arg)
   (cond
    ((string-ci=? "A" arg)
+    (log (syslog-level debug) "changed type to ascii")
     (set-session-type 'ascii))
    ((string-ci=? "I" arg)
+    (log (syslog-level debug) "changed type to image")
     (set-session-type 'image))
    ((string-ci=? "L8" arg)
+    (log (syslog-level debug) "changed type to image")
     (set-session-type 'image))
    (else
+    (log (syslog-level debug)
+	 "rejecting TYPE-command: unknown type (504)")
     (signal-error! 504
-		   (format #f "Unknown TYPE: ~A." arg))))
+		   (format #f "Unknown TYPE: ~S." arg))))
 
+  (log (syslog-level debug) "reporting new type (see previous log) (200)")
   (register-reply! 200
 		   (format #f "TYPE is now ~A."
 			   (case (session-type)
@@ -544,35 +637,47 @@
 			     (else "somethin' weird, man")))))
 
 (define (handle-mode arg)
+  (log-command "MODE" arg)
   (cond
    ((string=? "" arg)
+    (log (syslog-level debug) "rejecting MODE-command: no arguments (500)")
     (register-reply! 500
 		     "No arguments.  Not to worry---I'd ignore them anyway."))
    ((string-ci=? "S" arg)
+    (log (syslog-level debug) 
+	 "stream mode is (still) used for file-transfer (200)")
     (register-reply! 200 "Using stream mode to transfer files."))
    (else
+    (log (syslog-level debug) "mode ~S is not supported (504)" arg)
     (register-reply! 504 (format #f "Mode \"~A\" is not supported."
 				 arg)))))
 
 (define (handle-stru arg)
+  (log-command "STRU" arg)
   (cond
    ((string=? "" arg)
+    (log (syslog-level debug) "rejecting STRU-command: no arguments (500)")
     (register-reply! 500
 		     "No arguments.  Not to worry---I'd ignore them anyway."))
    ((string-ci=? "F" arg)
+    (log (syslog-level debug) "(still) using file structure to tranfser files (200)")
     (register-reply! 200 "Using file structure to transfer files."))
    (else
+    (log (syslog-level debug) "file structure ~S is not supported (504)" arg)
     (register-reply! 504
 		     (format #f "File structure \"~A\" is not supported."
 			     arg)))))
 
 (define (handle-noop arg)
+  (log-command "NOOP")
+  (log (syslog-level debug) "successfully done nothing (200)")
   (register-reply! 200 "Done nothing, but successfully."))
 
 (define *port-arg-regexp*
   (make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))
 
 (define (parse-port-arg string)
+  (log (syslog-level debug) "parsing port-string ~S" string)
   (cond
    ((regexp-exec *port-arg-regexp* string)
     => (lambda (match)
@@ -584,23 +689,32 @@
 	   (if (any? (lambda (component)
 		       (> component 255))
 		     components)
-	       (signal-error! 501
+	       (begin
-			      "Invalid arguments to PORT."))
+		 (log (syslog-level debug)
+		      "rejecting PORT-command because of invalid arguments (port-component > 255) (501)")
+		 (signal-error! 501
+				"Invalid arguments to PORT.")))
 	   (apply
 	    (lambda (a1 a2 a3 a4 p1 p2)
-	      (values (+ (arithmetic-shift a1 24)
+	      (let ((address (+ (arithmetic-shift a1 24)
-			 (arithmetic-shift a2 16)
+				(arithmetic-shift a2 16)
-			 (arithmetic-shift a3 8)
+				(arithmetic-shift a3 8)
-			 a4)
+				a4))
-		      (+ (arithmetic-shift p1 8)
+		    (port (+ (arithmetic-shift p1 8) p2)))
-			 p2)))
+		(log (syslog-level debug)
+		     "port-parse result: address ~D, port ~D (from compononets: address: ~A, ~A, ~A, ~A, port: ~A, ~A)"
+		     address port
+		     a1 a2 a3 a4 p1 p2)
+		 (values address port)))
 	    components))))
    (else
+    (log (syslog-level debug) "reporting syntax error in argument (500)")
     (signal-error! 500
 		   "Syntax error in argument to PORT."))))
 
 
 (define (handle-port stuff)
+  (log-command "PORT" stuff)
   (ensure-authenticated-login)
   (maybe-close-data-connection)
   (call-with-values
@@ -608,7 +722,8 @@
    (lambda (address port)
      (let ((socket (create-socket protocol-family/internet
 				  socket-type/stream)))
-
+       (log (syslog-level debug)
+	    "created new socket (internet, stream, reusing address)")
        (set-socket-option socket level/socket socket/reuse-address #t)
 
        (connect-socket socket
@@ -617,13 +732,20 @@
        
        (set-session-data-socket socket)
 
-       (register-reply! 200
+       (let ((formatted-internet-host-address 
-			(format #f "Connected to ~A, port ~A."
+	      (format-internet-host-address address)))
-				(format-internet-host-address address)
+	 (log (syslog-level debug)
-				port))))))
+	      "connected to ~A, port ~A (200)" 
+	      formatted-internet-host-address port)
+
+	 (register-reply! 200
+			  (format #f "Connected to ~A, port ~A."
+				  formatted-internet-host-address 
+				  port)))))))
 
 
 (define (handle-pasv stuff)
+  (log-command "PASV")
   (ensure-authenticated-login)
   (maybe-close-data-connection)
   (let ((socket (create-socket protocol-family/internet
@@ -644,12 +766,16 @@
 
 	 (set-session-passive-socket socket)
 
-	 (register-reply! 227
+
-			  (format #f "Passive mode OK (~A,~A)"
+	 (let ((formatted-this-host-address 
-				  (format-internet-host-address 
+		(format-internet-host-address (this-host-address) ","))
-				   (this-host-address)
+	       (formatted-port (format-port port)))
-				   ",")
+	   (log (syslog-level debug) "accepting passive mode (on ~A,~A) (227)"
-				  (format-port port))))))))
+		formatted-this-host-address formatted-port)
+	   (register-reply! 227
+			    (format #f "Passive mode OK (~A,~A)"
+				    formatted-this-host-address
+				    formatted-port))))))))
 
 (define (this-host-address)
   (call-with-values
@@ -679,9 +805,11 @@
    (number->string (bitwise-and port 255))))
 
 (define (handle-nlst arg)
+  (log-command "NLST" arg)
   (handle-listing arg '()))
 
 (define (handle-list arg)
+  (log-command "LIST" arg)
   (handle-listing arg '(long)))
   
 (define (handle-listing arg preset-flags)
@@ -700,7 +828,9 @@
 
 	  (if (and (not (null? rest-args))
 		   (not (null? (cdr rest-args))))
-	      (signal-error! 501 "More than one path argument."))
+	      (begin
+		(log (syslog-level debug) "got more than one path argument (501")
+		(signal-error! 501 "More than one path argument.")))
 
 	  (let ((path (if (null? rest-args)
 			  ""
@@ -708,9 +838,15 @@
 		(flags (arguments->ls-flags flag-args)))
 
 	    (if (not flags)
-		(signal-error! 501 "Invalid flag(s)."))
+		(begin
+		  (log (syslog-level debug) "got invalid flags (501)")
+		  (signal-error! 501 "Invalid flag(s).")))
+	    (let ((all-flags (append preset-flags flags)))
+	      (log (syslog-level debug)
+		   "sending file-listing for path ~S with flags ~A"
+		   path all-flags)
 
-	    (generate-listing path (append preset-flags flags)))))))))
+	      (generate-listing path all-flags)))))))))
 
 ; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
 ; ENSURE-DATA-CONNECTION.
@@ -721,10 +857,14 @@
 						 path))))
     (with-errno-handler*
      (lambda (errno packet)
-       (signal-error! 451
+       (let ((error-reason (car packet)))
-		      (format #f "Can't access directory at ~A: ~A."
+	 (log (syslog-level debug) 
-			      path
+	      "can't access directory at ~A: ~A (451)"
-			      (car packet))))
+	      path error-reason)
+	 (signal-error! 451
+			(format #f "Can't access directory at ~A: ~A."
+				path
+				error-reason))))
      (lambda ()
        (with-cwd*
 	(file-name-directory full-path)
@@ -739,46 +879,66 @@
 		(socket:outport (session-data-socket))))))))))
 
 (define (handle-abor foo)
+  (log-command "ABOR")
   (maybe-close-data-connection)
+  (log (syslog-level debug) "closing data connection (226)")
   (register-reply! 226 "Closing data connection."))
 
 (define (handle-retr path)
+  (log-command "RETR")
   (ensure-authenticated-login)
   (let ((full-path (string-append (session-root-directory)
 				  (assemble-path (session-current-directory)
 						 path))))
     (with-fatal-error-handler*		; CALL-WITH-INPUT-FILE doesn't go through ERRNO
      (lambda (condition more)
+       (log (syslog-level debug) 
+	    "failed to open ~S for reading - replying error for file ~S (550)" 
+	    full-path path)
        (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)))
-	     (signal-error! 450
+	     (begin
-			    (format #f "\"~A\" is not a regular file."
+	       (log (syslog-level debug) 
-				    path)))
+		    "~S is not a regular file - replying error for ~S (450)" 
+		    full-path path)
+	       (signal-error! 450
+			      (format #f "\"~A\" is not a regular file."
+				      path))))
 	 (call-with-input-file full-path
 	   (lambda (file-port)
 	     (with-data-connection
 	      (lambda ()
 		(case (session-type)
 		  ((image)
+		   (log (syslog-level debug) 
+			"sending file ~S in binary mode from port ~S"
+			full-path file-port)
 		   (copy-port->port-binary
 		    file-port
 		    (socket:outport (session-data-socket))))
 		  ((ascii)
+		   (log (syslog-level debug) 
+			"sending file ~S in ascii mode from port ~S"
+			full-path file-port)
 		   (copy-port->port-ascii
 		    file-port
 		    (socket:outport (session-data-socket))))))))))))))
 
 (define (handle-stor path)
+  (log-command "STOR" path)
   (ensure-authenticated-login)
   (let ((full-path (string-append (session-root-directory)
 				  (assemble-path (session-current-directory)
 						 path))))
     (with-fatal-error-handler*
      (lambda (condition more)
+       (log (syslog-level debug)
+	    "can't open ~S for writing -- replying error for ~S (550)"
+	    full-path path)
        (signal-error! 550
 		      (format #f "Can't open \"~A\" for writing."
 			      path)))
@@ -787,15 +947,22 @@
 	 (lambda (file-port)
 	   (with-data-connection
 	    (lambda ()
-	      (case (session-type)
+	      (let ((inport (socket:inport (session-data-socket))))
-		((image)
+		(case (session-type)
-		 (copy-port->port-binary
+		  ((image)
-		  (socket:inport (session-data-socket))
+		   (log (syslog-level debug)
-		  file-port))
+			"storing data to ~S from socket-inport ~S (binary-mode)"
+			full-path inport)
+		   (copy-port->port-binary
+		    (socket:inport (session-data-socket))
+		    file-port))
 		((ascii)
+		 (log (syslog-level debug)
+		      "storing data to ~S from socket-inport ~S (ascii-mode)"
+		      full-path inport)
 		 (copy-ascii-port->port
 		  (socket:inport (session-data-socket))
-		  file-port)))))))))))
+		  file-port))))))))))))
   
 (define (assemble-path current-directory path)
   (log (syslog-level debug) "assembling path ~S"
@@ -808,7 +975,7 @@
 	 (complete-path (if (file-name-rooted? interim-path)
 			    (file-name-sans-rooted interim-path)
 			    interim-path)))
-    (log (syslog-level debug) "path ~S assembled to ~S"
+    (log (syslog-level debug) "name ~S assembled to ~S"
 	 path complete-path)
     (cond
      ((normalize-path complete-path)
@@ -822,9 +989,10 @@
   (if (or (not (session-logged-in?))
 	  (not (session-authenticated?))) 
       (begin
-	(log (syslog-level debug) "login authentication failed - user is not logged in (530)")
+	(log (syslog-level debug) 
+	     "login authentication failed - user is not logged in (530)")
 	(signal-error! 530 "You're not logged in yet."))
-      (log (syslog-level debug) "authenticated login ensured.")))
+      (log (syslog-level debug) "authenticated login ensured")))
 
 (define (with-data-connection thunk)
   (dynamic-wind ensure-data-connection
@@ -836,7 +1004,9 @@
 (define (ensure-data-connection)
   (if (and (not (session-data-socket)) 
 	   (not (session-passive-socket)))
-      (signal-error! 425 "No data connection."))
+      (begin 
+	(log (syslog-level debug) "no data connection (425)")
+	(signal-error! 425 "No data connection.")))
 
   (if (session-passive-socket)
       (call-with-values
@@ -844,6 +1014,7 @@
        (lambda (socket socket-address)
 	 (set-session-data-socket socket))))
 
+  (log (syslog-level debug) "opening data connection (150)")
   (register-reply! 150 "Opening data connection.")
   (write-replies)
 
@@ -861,6 +1032,7 @@
       (close-socket (session-data-socket)))
   (if (session-passive-socket)
       (close-socket (session-passive-socket)))
+  (log (syslog-level debug) "closing data connection (226)")
   (register-reply! 226 "Closing data connection.")
   (set-session-data-socket #f)
   (set-session-passive-socket #f))
@@ -972,7 +1144,7 @@
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.22 $")
+(define *ftpd-version* "$Revision: 1.23 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))

modules.scm

@@ -424,7 +424,7 @@
 	structure-refs
 	handle-fatal-error
 	scsh
-	threads threads-internal
+	threads threads-internal    ; last one to get CURRENT-THREAD
 	fluids
 	string-lib
 	big-util

stringhax.scm

@@ -74,16 +74,18 @@
     (lambda (s) (char-set-index s non-whitespace))))
 
 ; Why is this so complicated?
-; Hope, it isn't anymore *g*  Andreas
+; I hope it isn't anymore *g*  Andreas
-
-(define (trim-spaces string)
-  (let* ((the-loop 
-	  (lambda (start incr)
-	    (let lp ((i start))
-	      (if (char=? #\space (string-ref string i))
-		  (lp (+ i incr))
-		  i))))
-	 (start (the-loop 0 1))
-	 (end (+ 1 (the-loop (- (string-length string) 1) -1))))
-    (substring string start end)))
 
+(define (trim-spaces string)  ; trims spaces from left and right 
+  (if (string=? "" string)
+      string
+      (let* ((the-loop 
+	      (lambda (start incr)    ; start-point and increment (+1 or -1)
+		(let lp ((i start))
+		  (if (char=? #\space (string-ref string i))
+		      (lp (+ i incr)) ; still spaces, go ahead
+		      i))))           ; first non-space-character
+	     (start (the-loop 0 1))   ; from left
+	     (end (+ 1 (the-loop (- (string-length string) 1) -1)))) ; from right
+	(substring string start end)))) ; in the middle
+  

uri.scm

@@ -271,8 +271,8 @@
 ;;; URL try to find out if it is a relative path (i.e. it does not
 ;;; start with a "/").
 
-(define (simplify-uri-path p) 
+(define (simplify-uri-path p)    
-  (if (null? p) #f                              ; P must be non-null
+  (if (null? p) #f                               ; P must be non-null
       (let lp ((path-list (cdr p))
 	       (stack (list (car p))))
 	(if (null? path-list)                   ; we're done
@@ -290,3 +290,4 @@
 	   (else                                ; usual segment
 	    (lp (cdr path-list) (cons (car path-list) stack))))))))
 	  
+