scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Changed syslog-levels for following facilities: 

changes concerning CONNECTIONS and the PUT (STOR) command are logged as NOTICE
GET (RETR) command and all other commands are logged as INFO
every thing else is logged as DEBUG

internal errors, unix errors and the reaching of unreachable case-branches are logged as NOTICE
success (as long as interesting) and failure of commands are logged as INFO

the debug messages are to used in cooperation with the other levels, so if you want to do debugging, let all messages be put in one file.
This commit is contained in:
interp 2001-07-24 17:11:42 +00:00
parent cd5e03ec9a
commit 3cc5d8c837
1 changed files with 127 additions and 124 deletions

251
ftpd.scm
View File

@ -87,13 +87,13 @@
(apply format #f (string-append "(thread ~D) " format-message) (apply format #f (string-append "(thread ~D) " format-message)
(thread-uid (current-thread)) args))) (thread-uid (current-thread)) args)))
(define (log-command command-name . argument) (define (log-command level command-name . argument)
(if (null? argument) (if (null? argument)
(log (syslog-level debug) "handling ~A-command" command-name) (log level "handling ~A-command" command-name)
(if (not (null? (cdr argument))) (if (not (null? (cdr argument)))
(log (syslog-level debug) "handling ~A-command with arguments ~S" (log level "handling ~A-command with argument ~S"
command-name argument) command-name argument)
(log (syslog-level debug) "handling ~A-command with argument ~S" (log level "handling ~A-command with argument ~S" ; does this ever happen?
command-name (car argument))))) command-name (car argument)))))
@ -135,7 +135,7 @@
#f #f
(lambda () (lambda ()
(log (syslog-level notice) (log (syslog-level notice)
"starting on port ~D with ~S as anonymous home" "starting daemon on port ~D with ~S as anonymous home"
port (expand-file-name anonymous-home (cwd))) port (expand-file-name anonymous-home (cwd)))
(bind-listen-accept-loop (bind-listen-accept-loop
@ -164,21 +164,18 @@
((or (= errno errno/notconn) ((or (= errno errno/notconn)
;; this one can come out of SOCKET->STRING ;; this one can come out of SOCKET->STRING
(= errno errno/inval)) (= errno errno/inval))
(log (syslog-level info) (log (syslog-level notice)
"socket to ~A not connected any more - exiting" "socket to ~A not connected any more - exiting thread"
remote-address) remote-address)
(exit 'fick-dich-ins-knie)))) (exit 'fick-dich-ins-knie))))
(lambda () (lambda ()
(let ((socket-string (socket->string socket))) (let ((socket-string (socket->string socket)))
(log (syslog-level info) (log (syslog-level notice)
"new connection to ~S" "new connection to ~S"
remote-address) remote-address)
(log (syslog-level debug) (log (syslog-level debug) "socket: ~S" socket-string)
"got connection with socket ~S and address ~S"
socket-string
remote-address)
(handle-connection (socket:inport socket) (handle-connection (socket:inport socket)
(socket:outport socket) (socket:outport socket)
@ -189,10 +186,10 @@
socket-string) socket-string)
(shutdown-socket socket shutdown/sends+receives) (shutdown-socket socket shutdown/sends+receives)
(log (syslog-level info) (log (syslog-level notice)
"closing socket to ~A and finishing thread" remote-address) "closing connection to ~A and finishing thread" remote-address)
(log (syslog-level debug) (log (syslog-level debug)
"closing socket (~A) and finishing thread" socket-string) "closing socket ~S" socket-string)
(close-socket socket)))))))) (close-socket socket))))))))
(define (ftpd-inetd anonymous-home) (define (ftpd-inetd anonymous-home)
@ -202,15 +199,14 @@
#f #f
#f #f
(lambda () (lambda ()
(log (syslog-level info) (log (syslog-level notice)
"new connection on current input- and output-port with ~S as anonymous home" "new connection on current input- and output-port with ~S as anonymous home"
(expand-file-name anonymous-home (cwd))) (expand-file-name anonymous-home (cwd)))
(log (syslog-level debug) (log (syslog-level debug)
"new connection on current input-port ~A and current output-port ~A with ~S as anonymous home" "inport: ~A, outport: ~A"
(current-input-port) (current-input-port)
(current-output-port) (current-output-port))
(expand-file-name anonymous-home (cwd)))
(handle-connection (current-input-port) (handle-connection (current-input-port)
(current-output-port) (current-output-port)
@ -299,9 +295,10 @@
"Command line: ~A" "Command line: ~A"
command-line) command-line)
(cond ((eq? command-line 'timeout) (cond ((eq? command-line 'timeout)
(log (syslog-level debug) (log (syslog-level notice) "hit timeliimit of ~D seconds (421)"
"hit timelimit (~D seconds) -- closing control connection and quitting (421)"
timeout-seconds) timeout-seconds)
(log (syslog-level debug)
"so closing control connection and quitting")
(register-reply! (register-reply!
421 421
(format #f "Timeout (~D seconds): closing control connection." (format #f "Timeout (~D seconds): closing control connection."
@ -331,9 +328,10 @@
(condition-stuff condition))) (condition-stuff condition)))
(escape 'fick-dich-ins-knie)) (escape 'fick-dich-ins-knie))
((ftpd-error? condition) ((ftpd-error? condition)
(log (syslog-level debug) ; debug level because nearly every unsuccessful command ends
"ftpd error occured: ~S -- escaping" ; here (no args, can't change dir, etc.)
condition) (log (syslog-level debug)
"ftpd error occured -- escaping")
(escape 'fick-dich-ins-knie)) (escape 'fick-dich-ins-knie))
(else (else
(more)))) (more))))
@ -373,10 +371,10 @@
(define (handle-user name) (define (handle-user name)
(log-command "USER" name) (log-command (syslog-level info) "USER" name)
(cond (cond
((session-logged-in?) ((session-logged-in?)
(log (syslog-level debug) "user ~S is already logged in (230)" (log (syslog-level info) "user ~S is already logged in (230)"
name) name)
(register-reply! 230 (register-reply! 230
"You are already logged in.")) "You are already logged in."))
@ -384,12 +382,12 @@
(string=? "ftp" name)) (string=? "ftp" name))
(handle-user-anonymous)) (handle-user-anonymous))
(else (else
(log (syslog-level debug) "rejecting non-anonymous login (530)") (log (syslog-level info) "rejecting non-anonymous login (530)")
(register-reply! 530 (register-reply! 530
"Only anonymous logins allowed.")))) "Only anonymous logins allowed."))))
(define (handle-user-anonymous) (define (handle-user-anonymous)
(log (syslog-level debug) "anonymous user login (230)") (log (syslog-level info) "anonymous user login (230)")
(set-session-logged-in? #t) (set-session-logged-in? #t)
(set-session-authenticated? #t) (set-session-authenticated? #t)
(set-session-anonymous? #t) (set-session-anonymous? #t)
@ -399,38 +397,38 @@
(register-reply! 230 "Anonymous user logged in.")) (register-reply! 230 "Anonymous user logged in."))
(define (handle-pass password) (define (handle-pass password)
(log-command "PASS" password) (log-command (syslog-level info) "PASS" password)
(cond (cond
((not (session-logged-in?)) ((not (session-logged-in?))
(log (syslog-level debug) "Rejecting password as user is not logged in yet. (530)") (log (syslog-level info) "Rejecting password as user has not logged in yet. (530)")
(register-reply! 530 "You have not logged in yet.")) (register-reply! 530 "You have not logged in yet."))
((session-anonymous?) ((session-anonymous?)
(log (syslog-level debug) "Accepting password as user is logged in. (200)") (log (syslog-level info) "Accepting password as user is logged in (200)")
(register-reply! 200 "Thank you.")) (register-reply! 200 "Thank you."))
(else (else
(log (syslog-level notice) "Reached unreachable case-branch while handling password! (502)") (log (syslog-level notice) "Reached unreachable case-branch while handling password (502)")
(register-reply! 502 "This can't happen.")))) (register-reply! 502 "This can't happen."))))
(define (handle-quit foo) (define (handle-quit foo)
(log-command "QUIT") (log-command (syslog-level info) "QUIT")
(log (syslog-level debug) "quitting (221)") (log (syslog-level debug) "quitting (221)")
(register-reply! 221 "Goodbye! Au revoir! Auf Wiedersehen!") (register-reply! 221 "Goodbye! Au revoir! Auf Wiedersehen!")
(signal 'ftpd-quit)) (signal 'ftpd-quit))
(define (handle-syst foo) (define (handle-syst foo)
(log-command "SYST") (log-command (syslog-level info) "SYST")
(log (syslog-level debug) "telling system type (215)") (log (syslog-level debug) "telling system type (215)")
(register-reply! 215 "UNIX Type: L8")) (register-reply! 215 "UNIX Type: L8"))
(define (handle-cwd path) (define (handle-cwd path)
(log-command "CWD" path) (log-command (syslog-level info) "CWD" path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((current-directory (assemble-path (session-current-directory) (let ((current-directory (assemble-path (session-current-directory)
path))) path)))
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(let ((error-reason (car packet))) (let ((error-reason (car packet)))
(log (syslog-level debug) (log (syslog-level info)
"can't change to directory \"~A\": ~A (550)" "can't change to directory \"~A\": ~A (550)"
path error-reason) path error-reason)
(signal-error! 550 (signal-error! 550
@ -442,7 +440,7 @@
(file-name-as-directory (file-name-as-directory
(string-append (session-root-directory) current-directory)) (string-append (session-root-directory) current-directory))
(lambda () ; I hate gratuitous syntax (lambda () ; I hate gratuitous syntax
(log (syslog-level debug) (log (syslog-level info)
"changing current directory to \"/~A\" (250)" "changing current directory to \"/~A\" (250)"
current-directory) current-directory)
(set-session-current-directory current-directory) (set-session-current-directory current-directory)
@ -451,14 +449,14 @@
current-directory)))))))) current-directory))))))))
(define (handle-cdup foo) (define (handle-cdup foo)
(log-command "CDUP") (log-command (syslog-level info) "CDUP")
(handle-cwd "..")) (handle-cwd ".."))
(define (handle-pwd foo) (define (handle-pwd foo)
(log-command "PWD") (log-command (syslog-level info) "PWD")
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((current-directory (session-current-directory))) (let ((current-directory (session-current-directory)))
(log (syslog-level debug) "replying \"/~A\" as current directory (257)" (log (syslog-level info) "replying \"/~A\" as current directory (257)"
current-directory) current-directory)
(register-reply! 257 (register-reply! 257
(format #f "Current directory is \"/~A\"." (format #f "Current directory is \"/~A\"."
@ -470,7 +468,7 @@
(ensure-authenticated-login) (ensure-authenticated-login)
(if (string=? "" path) (if (string=? "" path)
(begin (begin
(log (syslog-level debug) (log (syslog-level info)
"finishing processing command because of missing arguments (500)") "finishing processing command because of missing arguments (500)")
(signal-error! 500 "No argument."))) (signal-error! 500 "No argument.")))
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
@ -479,7 +477,7 @@
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(let ((error-reason (car packet))) (let ((error-reason (car packet)))
(log (syslog-level debug) (log (syslog-level info)
(string-append error-format-string " (550)") path error-reason) (string-append error-format-string " (550)") path error-reason)
(signal-error! 550 (signal-error! 550
(format #f error-format-string (format #f error-format-string
@ -491,21 +489,21 @@
(make-file-action-handler (make-file-action-handler
"Could not delete \"~A\": ~A." "Could not delete \"~A\": ~A."
(lambda (path full-path) (lambda (path full-path)
(log-command "DELE" path) (log-command (syslog-level info) "DELE" path)
(delete-file full-path) (delete-file full-path)
(log (syslog-level debug) "deleted ~S, reporting deletion of ~S (250)" (log (syslog-level info) "deleted ~S (250)" full-path)
full-path path) (log (syslog-level debug) "reporting about ~S" path)
(register-reply! 250 (format #f "Deleted \"~A\"." path))))) (register-reply! 250 (format #f "Deleted \"~A\"." path)))))
(define handle-mdtm (define handle-mdtm
(make-file-action-handler (make-file-action-handler
"Could not get info on \"~A\": ~A." "Could not get info on \"~A\": ~A."
(lambda (path full-path) (lambda (path full-path)
(log-command "MDTM" path) (log-command (syslog-level info) "MDTM" path)
(let* ((info (file-info full-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))) (formatted-date (format-date "~Y~m~d~H~M~S" the-date)))
(log (syslog-level debug) "reporting modification time of ~S: ~A (213)" (log (syslog-level info) "reporting modification time of ~S: ~A (213)"
full-path full-path
formatted-date) formatted-date)
(register-reply! 213 (register-reply! 213
@ -515,11 +513,10 @@
(make-file-action-handler (make-file-action-handler
"Could not make directory \"~A\": ~A." "Could not make directory \"~A\": ~A."
(lambda (path full-path) (lambda (path full-path)
(log-command "MKD" path) (log-command (syslog-level info) "MKD" path)
(create-directory full-path #o755) (create-directory full-path #o755)
(log (syslog-level debug) (log (syslog-level info) "created directory ~S (257)" full-path)
"created directory ~S, reporting creation of directory ~S (257)" (log (syslog-level debug) "reporting about ~S" path)
full-path path)
(register-reply! 257 (register-reply! 257
(format #f "Created directory \"~A\"." path))))) (format #f "Created directory \"~A\"." path)))))
@ -527,11 +524,10 @@
(make-file-action-handler (make-file-action-handler
"Could not remove directory \"~A\": ~A." "Could not remove directory \"~A\": ~A."
(lambda (path full-path) (lambda (path full-path)
(log-command "RMD" path) (log-command (syslog-level info) "RMD" path)
(delete-directory full-path) (delete-directory full-path)
(log (syslog-level debug) (log (syslog-level info) "deleted directory ~S (250)" full-path)
"deleted directory ~S, reporting deletion of directory ~S (250)" (log (syslog-level debug) "reporting about ~S" path)
full-path path)
(register-reply! 250 (register-reply! 250
(format #f "Deleted directory \"~A\"." path))))) (format #f "Deleted directory \"~A\"." path)))))
@ -540,24 +536,24 @@
(make-file-action-handler (make-file-action-handler
"Could not get info on file \"~A\": ~A." "Could not get info on file \"~A\": ~A."
(lambda (path full-path) (lambda (path full-path)
(log-command "RNFR" path) (log-command (syslog-level info) "RNFR" path)
(file-info full-path) (file-info full-path)
(log (syslog-level debug) (log (syslog-level info)
"RNFR-command accepted, waiting for RNTO-command (350)") "RNFR-command accepted, waiting for RNTO-command (350)")
(register-reply! 350 "RNFR accepted. Gimme a RNTO next.") (register-reply! 350 "RNFR accepted. Gimme a RNTO next.")
(set-session-to-be-renamed full-path)))) (set-session-to-be-renamed full-path))))
(define (handle-rnto path) (define (handle-rnto path)
(log-command "RNTO" path) (log-command (syslog-level info) "RNTO" path)
(ensure-authenticated-login) (ensure-authenticated-login)
(if (not (session-to-be-renamed)) (if (not (session-to-be-renamed))
(begin (begin
(log (syslog-level debug) (log (syslog-level info)
"RNTO-command rejected: need RNFR-command before (503)") "RNTO-command rejected: need RNFR-command before (503)")
(signal-error! 503 "Need RNFR before RNTO."))) (signal-error! 503 "Need RNFR before RNTO.")))
(if (string=? "" path) (if (string=? "" path)
(begin (begin
(log (syslog-level debug) (log (syslog-level info)
"No argument -- still waiting for (correct) RNTO-command (500)") "No argument -- still waiting for (correct) RNTO-command (500)")
(signal-error! 500 "No argument."))) (signal-error! 500 "No argument.")))
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
@ -566,9 +562,10 @@
(if (file-exists? full-path) (if (file-exists? full-path)
(begin (begin
(log (syslog-level debug) (log (syslog-level info) "rename of ~S failed (already exists) (550)"
"rename of ~S failed (already exists), reporting failure of renaming ~S (550)" full-path)
full-path path) (log (syslog-level debug) "reporting about ~S"
path)
(signal-error! (signal-error!
550 550
(format #f "Rename failed---\"~A\" already exists or is protected." (format #f "Rename failed---\"~A\" already exists or is protected."
@ -576,14 +573,14 @@
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(log (syslog-level debug) (log (syslog-level info)
"failed to rename ~A (550)" path) "failed to rename ~A (550)" path)
(signal-error! 550 (signal-error! 550
(format #f "Could not rename: ~A." path))) (format #f "Could not rename: ~A." path)))
(lambda () (lambda ()
(let ((old-name (session-to-be-renamed))) (let ((old-name (session-to-be-renamed)))
(rename-file old-name full-path) (rename-file old-name full-path)
(log (syslog-level debug) (log (syslog-level info)
"~S renamed to ~S - no more waiting for RNTO-command (250)" "~S renamed to ~S - no more waiting for RNTO-command (250)"
old-name full-path) old-name full-path)
(register-reply! 250 "File renamed.") (register-reply! 250 "File renamed.")
@ -593,42 +590,43 @@
(make-file-action-handler (make-file-action-handler
"Could not get info on file \"~A\": ~A." "Could not get info on file \"~A\": ~A."
(lambda (path full-path) (lambda (path full-path)
(log-command "SIZE" path) (log-command (syslog-level info) "SIZE" path)
(let ((info (file-info full-path))) (let ((info (file-info full-path)))
(if (not (eq? 'regular (file-info:type info))) (if (not (eq? 'regular (file-info:type info)))
(begin (begin
(log (syslog-level debug) (log (syslog-level info)
"rejecting SIZE-command as ~S is not a regular file, reporting on ~S (550)" "rejecting SIZE-command as ~S is not a regular file (550)"
full-path path) full-path)
(log (syslog-level debug) "reporting about ~S" path)
(signal-error! 550 (signal-error! 550
(format #f "\"~A\" is not a regular file." (format #f "\"~A\" is not a regular file."
path)))) path))))
(let ((file-size (file-info:size info))) (let ((file-size (file-info:size info)))
(log (syslog-level debug) (log (syslog-level info)
"reporting ~D as size of ~S (213)" "reporting ~D as size of ~S (213)"
file-size full-path) file-size full-path)
(register-reply! 213 (number->string file-size))))))) (register-reply! 213 (number->string file-size)))))))
(define (handle-type arg) (define (handle-type arg)
(log-command "TYPE" arg) (log-command (syslog-level info) "TYPE" arg)
(cond (cond
((string-ci=? "A" arg) ((string-ci=? "A" arg)
(log (syslog-level debug) "changed type to ascii") (log (syslog-level info) "changed type to ascii (200)")
(set-session-type 'ascii)) (set-session-type 'ascii))
((string-ci=? "I" arg) ((string-ci=? "I" arg)
(log (syslog-level debug) "changed type to image") (log (syslog-level info) "changed type to image (8-bit binary) (200)")
(set-session-type 'image)) (set-session-type 'image))
((string-ci=? "L8" arg) ((string-ci=? "L8" arg)
(log (syslog-level debug) "changed type to image") (log (syslog-level info) "changed type to image (8-bit binary) (200)")
(set-session-type 'image)) (set-session-type 'image))
(else (else
(log (syslog-level debug) (log (syslog-level info)
"rejecting TYPE-command: unknown type (504)") "rejecting TYPE-command: unknown type (504)")
(signal-error! 504 (signal-error! 504
(format #f "Unknown TYPE: ~S." arg)))) (format #f "Unknown TYPE: ~S." arg))))
(log (syslog-level debug) "reporting new type (see previous log) (200)") (log (syslog-level debug) "reporting new type (see above)")
(register-reply! 200 (register-reply! 200
(format #f "TYPE is now ~A." (format #f "TYPE is now ~A."
(case (session-type) (case (session-type)
@ -637,39 +635,39 @@
(else "somethin' weird, man"))))) (else "somethin' weird, man")))))
(define (handle-mode arg) (define (handle-mode arg)
(log-command "MODE" arg) (log-command (syslog-level info) "MODE" arg)
(cond (cond
((string=? "" arg) ((string=? "" arg)
(log (syslog-level debug) "rejecting MODE-command: no arguments (500)") (log (syslog-level info) "rejecting MODE-command: no arguments (500)")
(register-reply! 500 (register-reply! 500
"No arguments. Not to worry---I'd ignore them anyway.")) "No arguments. Not to worry---I'd ignore them anyway."))
((string-ci=? "S" arg) ((string-ci=? "S" arg)
(log (syslog-level debug) (log (syslog-level info)
"stream mode is (still) used for file-transfer (200)") "stream mode is (still) used for file-transfer (200)")
(register-reply! 200 "Using stream mode to transfer files.")) (register-reply! 200 "Using stream mode to transfer files."))
(else (else
(log (syslog-level debug) "mode ~S is not supported (504)" arg) (log (syslog-level info) "mode ~S is not supported (504)" arg)
(register-reply! 504 (format #f "Mode \"~A\" is not supported." (register-reply! 504 (format #f "Mode \"~A\" is not supported."
arg))))) arg)))))
(define (handle-stru arg) (define (handle-stru arg)
(log-command "STRU" arg) (log-command (syslog-level info) "STRU" arg)
(cond (cond
((string=? "" arg) ((string=? "" arg)
(log (syslog-level debug) "rejecting STRU-command: no arguments (500)") (log (syslog-level info) "rejecting STRU-command: no arguments (500)")
(register-reply! 500 (register-reply! 500
"No arguments. Not to worry---I'd ignore them anyway.")) "No arguments. Not to worry---I'd ignore them anyway."))
((string-ci=? "F" arg) ((string-ci=? "F" arg)
(log (syslog-level debug) "(still) using file structure to tranfser files (200)") (log (syslog-level info) "(still) using file structure to tranfser files (200)")
(register-reply! 200 "Using file structure to transfer files.")) (register-reply! 200 "Using file structure to transfer files."))
(else (else
(log (syslog-level debug) "file structure ~S is not supported (504)" arg) (log (syslog-level info) "file structure ~S is not supported (504)" arg)
(register-reply! 504 (register-reply! 504
(format #f "File structure \"~A\" is not supported." (format #f "File structure \"~A\" is not supported."
arg))))) arg)))))
(define (handle-noop arg) (define (handle-noop arg)
(log-command "NOOP") (log-command (syslog-level info) "NOOP")
(log (syslog-level debug) "successfully done nothing (200)") (log (syslog-level debug) "successfully done nothing (200)")
(register-reply! 200 "Done nothing, but successfully.")) (register-reply! 200 "Done nothing, but successfully."))
@ -714,7 +712,7 @@
(define (handle-port stuff) (define (handle-port stuff)
(log-command "PORT" stuff) (log-command (syslog-level info) "PORT" stuff)
(ensure-authenticated-login) (ensure-authenticated-login)
(maybe-close-data-connection) (maybe-close-data-connection)
(call-with-values (call-with-values
@ -734,7 +732,7 @@
(let ((formatted-internet-host-address (let ((formatted-internet-host-address
(format-internet-host-address address))) (format-internet-host-address address)))
(log (syslog-level debug) (log (syslog-level info)
"connected to ~A, port ~A (200)" "connected to ~A, port ~A (200)"
formatted-internet-host-address port) formatted-internet-host-address port)
@ -745,7 +743,7 @@
(define (handle-pasv stuff) (define (handle-pasv stuff)
(log-command "PASV") (log-command (syslog-level info) "PASV")
(ensure-authenticated-login) (ensure-authenticated-login)
(maybe-close-data-connection) (maybe-close-data-connection)
(let ((socket (create-socket protocol-family/internet (let ((socket (create-socket protocol-family/internet
@ -770,7 +768,7 @@
(let ((formatted-this-host-address (let ((formatted-this-host-address
(format-internet-host-address (this-host-address) ",")) (format-internet-host-address (this-host-address) ","))
(formatted-port (format-port port))) (formatted-port (format-port port)))
(log (syslog-level debug) "accepting passive mode (on ~A,~A) (227)" (log (syslog-level info) "accepting passive mode (on ~A,~A) (227)"
formatted-this-host-address formatted-port) formatted-this-host-address formatted-port)
(register-reply! 227 (register-reply! 227
(format #f "Passive mode OK (~A,~A)" (format #f "Passive mode OK (~A,~A)"
@ -805,11 +803,11 @@
(number->string (bitwise-and port 255)))) (number->string (bitwise-and port 255))))
(define (handle-nlst arg) (define (handle-nlst arg)
(log-command "NLST" arg) (log-command (syslog-level info) "NLST" arg)
(handle-listing arg '())) (handle-listing arg '()))
(define (handle-list arg) (define (handle-list arg)
(log-command "LIST" arg) (log-command (syslog-level info) "LIST" arg)
(handle-listing arg '(long))) (handle-listing arg '(long)))
(define (handle-listing arg preset-flags) (define (handle-listing arg preset-flags)
@ -829,7 +827,7 @@
(if (and (not (null? rest-args)) (if (and (not (null? rest-args))
(not (null? (cdr rest-args)))) (not (null? (cdr rest-args))))
(begin (begin
(log (syslog-level debug) "got more than one path argument (501") (log (syslog-level info) "got more than one path argument - rejection (501)")
(signal-error! 501 "More than one path argument."))) (signal-error! 501 "More than one path argument.")))
(let ((path (if (null? rest-args) (let ((path (if (null? rest-args)
@ -839,10 +837,10 @@
(if (not flags) (if (not flags)
(begin (begin
(log (syslog-level debug) "got invalid flags (501)") (log (syslog-level info) "got invalid flags (501)")
(signal-error! 501 "Invalid flag(s)."))) (signal-error! 501 "Invalid flag(s).")))
(let ((all-flags (append preset-flags flags))) (let ((all-flags (append preset-flags flags)))
(log (syslog-level debug) (log (syslog-level info)
"sending file-listing for path ~S with flags ~A" "sending file-listing for path ~S with flags ~A"
path all-flags) path all-flags)
@ -858,7 +856,7 @@
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(let ((error-reason (car packet))) (let ((error-reason (car packet)))
(log (syslog-level debug) (log (syslog-level info)
"can't access directory at ~A: ~A (451)" "can't access directory at ~A: ~A (451)"
path error-reason) path error-reason)
(signal-error! 451 (signal-error! 451
@ -879,22 +877,21 @@
(socket:outport (session-data-socket)))))))))) (socket:outport (session-data-socket))))))))))
(define (handle-abor foo) (define (handle-abor foo)
(log-command "ABOR") (log-command (syslog-level info) "ABOR")
(maybe-close-data-connection) (maybe-close-data-connection)
(log (syslog-level debug) "closing data connection (226)") (log (syslog-level info) "closing data connection (226)")
(register-reply! 226 "Closing data connection.")) (register-reply! 226 "Closing data connection."))
(define (handle-retr path) (define (handle-retr path)
(log-command "RETR") (log-command (syslog-level info) "RETR")
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
(assemble-path (session-current-directory) (assemble-path (session-current-directory)
path)))) path))))
(with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO (with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO
(lambda (condition more) (lambda (condition more)
(log (syslog-level debug) (log (syslog-level info) "failed to open ~S for reading (550)" full-path)
"failed to open ~S for reading - replying error for file ~S (550)" (log (syslog-level debug) "reporting about ~S" path)
full-path path)
(signal-error! 550 (signal-error! 550
(format #f "Can't open \"~A\" for reading." (format #f "Can't open \"~A\" for reading."
path))) path)))
@ -902,9 +899,9 @@
(let ((info (file-info full-path))) (let ((info (file-info full-path)))
(if (not (eq? 'regular (file-info:type info))) (if (not (eq? 'regular (file-info:type info)))
(begin (begin
(log (syslog-level debug) (log (syslog-level info) "rejecting RETR-command as ~S is not a regular file (450)"
"~S is not a regular file - replying error for ~S (450)" full-path)
full-path path) (log (syslog-level debug) "reporting about ~S" path)
(signal-error! 450 (signal-error! 450
(format #f "\"~A\" is not a regular file." (format #f "\"~A\" is not a regular file."
path)))) path))))
@ -914,31 +911,31 @@
(lambda () (lambda ()
(case (session-type) (case (session-type)
((image) ((image)
(log (syslog-level debug) (log (syslog-level info)
"sending file ~S in binary mode from port ~S" "sending file ~S (binary mode)"
full-path file-port) full-path)
(log (syslog-level debug) "sending is from port ~S" file-port)
(copy-port->port-binary (copy-port->port-binary
file-port file-port
(socket:outport (session-data-socket)))) (socket:outport (session-data-socket))))
((ascii) ((ascii)
(log (syslog-level debug) (log (syslog-level info) "sending file ~S (ascii mode)"
"sending file ~S in ascii mode from port ~S" full-path)
full-path file-port) (log (syslog-level debug) "sending is from port ~S" file-port)
(copy-port->port-ascii (copy-port->port-ascii
file-port file-port
(socket:outport (session-data-socket)))))))))))))) (socket:outport (session-data-socket))))))))))))))
(define (handle-stor path) (define (handle-stor path)
(log-command "STOR" path) (log-command (syslog-level info) "STOR" path)
(ensure-authenticated-login) (ensure-authenticated-login)
(let ((full-path (string-append (session-root-directory) (let ((full-path (string-append (session-root-directory)
(assemble-path (session-current-directory) (assemble-path (session-current-directory)
path)))) path))))
(with-fatal-error-handler* (with-fatal-error-handler*
(lambda (condition more) (lambda (condition more)
(log (syslog-level debug) (log (syslog-level info) "can't open ~S for writing (550)" full-path)
"can't open ~S for writing -- replying error for ~S (550)" (log (syslog-level debug) "replying error for file ~S" path)
full-path path)
(signal-error! 550 (signal-error! 550
(format #f "Can't open \"~A\" for writing." (format #f "Can't open \"~A\" for writing."
path))) path)))
@ -950,19 +947,25 @@
(let ((inport (socket:inport (session-data-socket)))) (let ((inport (socket:inport (session-data-socket))))
(case (session-type) (case (session-type)
((image) ((image)
(log (syslog-level notice)
"storing data to ~S (binary mode)"
full-path)
(log (syslog-level debug) (log (syslog-level debug)
"storing data to ~S from socket-inport ~S (binary-mode)" "storing comes from socket-inport ~S (binary-mode)"
full-path inport) inport)
(copy-port->port-binary (copy-port->port-binary
(socket:inport (session-data-socket)) (socket:inport (session-data-socket))
file-port)) file-port))
((ascii) ((ascii)
(log (syslog-level debug) (log (syslog-level notice)
"storing data to ~S from socket-inport ~S (ascii-mode)" "storing data to ~S (ascii-mode)"
full-path inport) full-path)
(copy-ascii-port->port (log (syslog-level debug)
(socket:inport (session-data-socket)) "storing comes from socket-inport ~S (ascii-mode)"
file-port)))))))))))) inport)
(copy-ascii-port->port
(socket:inport (session-data-socket))
file-port))))))))))))
(define (assemble-path current-directory path) (define (assemble-path current-directory path)
(log (syslog-level debug) "assembling path ~S" (log (syslog-level debug) "assembling path ~S"
@ -1144,7 +1147,7 @@
; Version ; Version
(define *ftpd-version* "$Revision: 1.23 $") (define *ftpd-version* "$Revision: 1.24 $")
(define (copy-port->port-binary input-port output-port) (define (copy-port->port-binary input-port output-port)
(let ((buffer (make-string *window-size*))) (let ((buffer (make-string *window-size*)))