From dbebe4e8efbe9a38ccd50e7aaa14351701db117d Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Sat, 7 Jul 2001 15:19:52 +0000
Subject: [PATCH] even more syslogs inserted

---
 ftpd.scm | 48 ++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 44 insertions(+), 4 deletions(-)

diff --git a/ftpd.scm b/ftpd.scm
index 573a172..783dceb 100644
--- a/ftpd.scm
+++ b/ftpd.scm
@@ -296,7 +296,8 @@
 	  (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 (??)
+	       "ftpd error occured: ~S -- escaping"  
+	       ; must this occur everytime CDUP is called in ftp-root-path?
 	       (condition-stuff condition))
 	  (escape 'fick-dich-ins-knie))
 	 (else
@@ -320,8 +321,13 @@
   (cond
    ((assoc command *command-alist*)
     => (lambda (pair)
+	 (log (syslog-level debug)
+	      "command ~S was found in command-list and is executed with argument ~S"
+	      (car pair) arg)
 	 ((cdr pair) arg)))
    (else
+    (log (syslog-level debug) "rejecting unknown command ~S (500) (argument: ~S)"
+	 command arg)
     (register-reply! 500
 		     (string-append
 		      (format #f "Unknown command: \"~A\"" command)
@@ -331,18 +337,24 @@
 
 
 (define (handle-user name)
+  (log (syslog-level debug) "handling USER-command with name ~S"
+       name)
   (cond
    ((session-logged-in?)
+    (log (syslog-level debug) "user ~S is already logged in (230)"
+	 name)
     (register-reply! 230
 		     "You are already logged in."))
    ((or (string=? "anonymous" name)
 	(string=? "ftp" name))
     (handle-user-anonymous))
    (else
+    (log (syslog-level debug) "rejecting non-anonymous login (530)")
     (register-reply! 530
 		     "Only anonymous logins allowed."))))
 
 (define (handle-user-anonymous)
+  (log (syslog-level debug) "anonymous user login (230)")
   (set-session-logged-in? #t)
   (set-session-authenticated? #t)
   (set-session-anonymous? #t)
@@ -352,26 +364,38 @@
   (register-reply! 230 "Anonymous user logged in."))
 
 (define (handle-pass password)
+  (log (syslog-level debug) "handling PASS-command with password ~S"
+       password)
   (cond
    ((not (session-logged-in?))
+    (log (syslog-level debug) "Rejecting password as user is not logged in yet. (530)")
     (register-reply! 530 "You have not logged in yet."))
    ((session-anonymous?)
+    (log (syslog-level debug) "Accepting password as user is logged in. (200)")
     (register-reply! 200 "Thank you."))
    (else
+    (log (syslog-level notice) "Reached unreachable case-branch while handling password! (502)")
     (register-reply! 502 "This can't happen."))))
 
 (define (handle-quit foo)
+  (log (syslog-level debug) "handling QUIT-command (221)")
   (register-reply! 221 "Goodbye!  Au revoir!  Auf Wiedersehen!")
   (signal 'ftpd-quit))
 
 (define (handle-syst foo)
+  (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"
+       path)
   (ensure-authenticated-login)
   (let ((current-directory (assemble-path path)))
     (with-errno-handler*
      (lambda (errno packet)
+       (log (syslog-level debug)
+	    "can't change to directory \"~A\": ~A (550)"
+	    path (car packet))
        (signal-error! 550
 			(format #f "Can't change directory to \"~A\": ~A."
 				path
@@ -381,16 +405,23 @@
 	(file-name-as-directory
 	 (string-append (session-root-directory) current-directory))
 	(lambda ()			; I hate gratuitous syntax
+	  (log (syslog-level debug)
+	       "changing current directory to \"/~A\" (250)"
+	       current-directory)
 	  (set-session-current-directory current-directory)
 	  (register-reply! 250
 			   (format #f "Current directory changed to \"/~A\"."
 				   current-directory))))))))
 
 (define (handle-cdup foo)
+  (log (syslog-level debug) "handling CDUP-command as \"CWD ..\"")
   (handle-cwd ".."))
 
 (define (handle-pwd foo)
+  (log (syslog-level debug) "handling PWD-command")
   (ensure-authenticated-login)
+  (log (syslog-level debug) "replying \"/~A\" as current directory (257)"
+       (session-current-directory))
   (register-reply! 257
 		   (format #f "Current directory is \"/~A\"."
 			   (session-current-directory))))
@@ -757,6 +788,8 @@
 		  file-port)))))))))))
   
 (define (assemble-path path)
+  (log (syslog-level debug) "assembling path ~S"
+       path)
   (let* ((interim-path
 	  (if (not (file-name-rooted? path))
 	      (string-append (file-name-as-directory 
@@ -766,16 +799,23 @@
 	 (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"
+	 path complete-path)
     (cond
      ((normalize-path complete-path)
       => (lambda (assembled-path) assembled-path))
      (else
+      (log (syslog-level debug) 
+	   "invalid pathname -- tried to pass root directory (501)")
       (signal-error! 501 "Invalid pathname")))))
 
 (define (ensure-authenticated-login)
   (if (or (not (session-logged-in?))
-	  (not (session-authenticated?)))
-      (signal-error! 530 "You're not logged in yet.")))
+	  (not (session-authenticated?))) 
+      (begin
+	(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.")))
 
 (define (with-data-connection thunk)
   (dynamic-wind ensure-data-connection
@@ -926,7 +966,7 @@
 
 ; Version
 
-(define *ftpd-version* "$Revision: 1.19 $")
+(define *ftpd-version* "$Revision: 1.20 $")
 
 (define (copy-port->port-binary input-port output-port)
   (let ((buffer (make-string *window-size*)))