even more syslogs inserted

This commit is contained in:
interp 2001-07-07 15:19:52 +00:00
parent e63ed67403
commit dbebe4e8ef
1 changed files with 44 additions and 4 deletions

View File

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