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