From 747f3cb054f4e377ce47e68480b2aa1d9d96a737 Mon Sep 17 00:00:00 2001 From: interp Date: Fri, 29 Jun 2001 15:10:28 +0000 Subject: [PATCH] added more syslog messages --- ftpd.scm | 90 ++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 65 insertions(+), 25 deletions(-) diff --git a/ftpd.scm b/ftpd.scm index e072d6b..573a172 100644 --- a/ftpd.scm +++ b/ftpd.scm @@ -69,11 +69,14 @@ (define set-session-data-socket (make-fluid-setter set-session:data-socket)) (define set-session-passive-socket (make-fluid-setter set-session:passive-socket)) -(define log - (lambda (level format-message . args) + +;;; LOG ------------------------------------------------------- +(define (log level format-message . args) (syslog level - (apply format #f format-message args)))) - + (apply format #f (string-append "(thread ~D) " format-message) + (thread-uid (current-thread)) args))) + +;;; CONVERTERS ------------------------------------------------ (define (protocol-family->string protocol-family) (cond ((= protocol-family protocol-family/unspecified) "unspecified") @@ -84,13 +87,14 @@ (else "unknown"))) (define (socket->string socket) - (format #f "family: ~A, local address: ~A, remote address: ~A, input-port ~A, output-port ~A" + (format #f "family: ~A, ~&local address: ~A, ~&remote address: ~A, ~&input-port ~A, ~&output-port ~A" (protocol-family->string (socket:family socket)) (socket-address->string (socket-local-address socket)) (socket-address->string (socket-remote-address socket)) (socket:inport socket) (socket:outport socket))) + (define (socket-address->string socket-address) (call-with-values (lambda () (socket-address->internet-address socket-address)) @@ -99,6 +103,8 @@ (format-internet-host-address host-address) (format-port service-port))))) +;;; ftpd ------------------------------------------------------- + (define (ftpd anonymous-home . maybe-port) (let ((port (optional maybe-port 21))) (with-syslog-destination @@ -141,9 +147,6 @@ ((= errno errno/notconn) (log (syslog-level warning) "socket not connected any more - exiting thread") - (log (syslog-level debug) - "socket ~S not connected any more" - (socket->string socket)) (exit 'fick-dich-ins-knie)))) (lambda () (log (syslog-level debug) @@ -186,10 +189,18 @@ (define (handle-connection input-port output-port anonymous-home) + (log (syslog-level debug) + "handling connection with input-port ~A, outputport ~A and home ~A" + input-port + output-port + anonymous-home) (call-with-current-continuation (lambda (escape) (with-handler (lambda (condition more) + (log (syslog-level debug) + "hit error condition ~A -- exiting" + (condition-type condition)) (display condition (current-error-port)) (escape 'fick-dich-ins-knie)) (lambda () @@ -200,6 +211,8 @@ (handle-commands)))))))) (define (display-banner) + (log (syslog-level debug) + "displaying banner") (register-reply! 220 (string-append "Scheme Untergrund ftp server (" @@ -217,35 +230,47 @@ (define (handle-commands) + (log (syslog-level debug) "handling commands") (call-with-current-continuation (lambda (exit) (with-handler (lambda (condition more) (if (ftpd-quit? condition) - (with-handler - (lambda (condition ignore) - (more)) - (lambda () - (write-replies) - (exit 'fick-dich-ins-knie))) + (begin + (log (syslog-level debug) "quitting") + (with-handler + (lambda (condition ignore) + (more)) + (lambda () + (write-replies) + (exit 'fick-dich-ins-knie)))) (more))) (lambda () + (log (syslog-level debug) + "starting write-accept-loop") (let loop () (write-replies) (accept-command) (loop))))))) (define (accept-command) - (let ((command-line (read-crlf-line-timeout (session-control-input-port) - #f - 90000 ; timeout - 500))) ; max interval - ;; (format #t "Command line: ~A~%" command-line) - (cond ((eq? command-line 'timeout) - (register-reply! - 421 - "Timeout (900 seconds): closing control connection.") - (signal 'ftpd-quit)) + (let* ((timeout-seconds 90) + (command-line (read-crlf-line-timeout (session-control-input-port) + #f + (* 1000 timeout-seconds);timeout + 500))) ; max interval + (log (syslog-level debug) + "Command line: ~A" + command-line) + (cond ((eq? command-line 'timeout) + (log (syslog-level debug) + "hit timelimit (~D seconds) -- closing control connection." + timeout-seconds) + (register-reply! + 421 + (format #f "Timeout (~D seconds): closing control connection." + timeout-seconds) + (signal 'ftpd-quit))) (else (call-with-values (lambda () (parse-command-line command-line)) @@ -253,23 +278,35 @@ (handle-command command arg))))))) (define (handle-command command arg) + (log (syslog-level debug) + "handling command ~S with argument ~S" + command arg) (call-with-current-continuation (lambda (escape) (with-handler (lambda (condition more) (cond ((error? condition) + (log (syslog-level notice) + "internal error occured: ~S -- replying (451) and escaping" + condition) (register-reply! 451 (format #f "Internal error: ~S" (condition-stuff condition))) (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 (??) + (condition-stuff condition)) (escape 'fick-dich-ins-knie)) (else (more)))) (lambda () (with-errno-handler* (lambda (errno packet) + (log (syslog-level notice) + "unix error occured: ~S -- replying (451) and escaping" + (car packet)) (register-reply! 451 (format #f "Unix error: ~A." (car packet))) (escape 'fick-dich-ins-knie)) @@ -277,6 +314,9 @@ (dispatch-command command arg)))))))) (define (dispatch-command command arg) + (log (syslog-level debug) + "dispatching command ~S with argument ~S" + command arg) (cond ((assoc command *command-alist*) => (lambda (pair) @@ -886,7 +926,7 @@ ; Version -(define *ftpd-version* "$Revision: 1.18 $") +(define *ftpd-version* "$Revision: 1.19 $") (define (copy-port->port-binary input-port output-port) (let ((buffer (make-string *window-size*)))