added more syslog messages

This commit is contained in:
interp 2001-06-29 15:10:28 +00:00
parent 5b666fb2e4
commit 747f3cb054
1 changed files with 65 additions and 25 deletions

View File

@ -69,11 +69,14 @@
(define set-session-data-socket (make-fluid-setter set-session:data-socket)) (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 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 (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) (define (protocol-family->string protocol-family)
(cond ((= protocol-family protocol-family/unspecified) (cond ((= protocol-family protocol-family/unspecified)
"unspecified") "unspecified")
@ -84,13 +87,14 @@
(else "unknown"))) (else "unknown")))
(define (socket->string socket) (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)) (protocol-family->string (socket:family socket))
(socket-address->string (socket-local-address socket)) (socket-address->string (socket-local-address socket))
(socket-address->string (socket-remote-address socket)) (socket-address->string (socket-remote-address socket))
(socket:inport socket) (socket:inport socket)
(socket:outport socket))) (socket:outport socket)))
(define (socket-address->string socket-address) (define (socket-address->string socket-address)
(call-with-values (call-with-values
(lambda () (socket-address->internet-address socket-address)) (lambda () (socket-address->internet-address socket-address))
@ -99,6 +103,8 @@
(format-internet-host-address host-address) (format-internet-host-address host-address)
(format-port service-port))))) (format-port service-port)))))
;;; ftpd -------------------------------------------------------
(define (ftpd anonymous-home . maybe-port) (define (ftpd anonymous-home . maybe-port)
(let ((port (optional maybe-port 21))) (let ((port (optional maybe-port 21)))
(with-syslog-destination (with-syslog-destination
@ -141,9 +147,6 @@
((= errno errno/notconn) ((= errno errno/notconn)
(log (syslog-level warning) (log (syslog-level warning)
"socket not connected any more - exiting thread") "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)))) (exit 'fick-dich-ins-knie))))
(lambda () (lambda ()
(log (syslog-level debug) (log (syslog-level debug)
@ -186,10 +189,18 @@
(define (handle-connection input-port output-port anonymous-home) (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 (call-with-current-continuation
(lambda (escape) (lambda (escape)
(with-handler (with-handler
(lambda (condition more) (lambda (condition more)
(log (syslog-level debug)
"hit error condition ~A -- exiting"
(condition-type condition))
(display condition (current-error-port)) (display condition (current-error-port))
(escape 'fick-dich-ins-knie)) (escape 'fick-dich-ins-knie))
(lambda () (lambda ()
@ -200,6 +211,8 @@
(handle-commands)))))))) (handle-commands))))))))
(define (display-banner) (define (display-banner)
(log (syslog-level debug)
"displaying banner")
(register-reply! 220 (register-reply! 220
(string-append (string-append
"Scheme Untergrund ftp server (" "Scheme Untergrund ftp server ("
@ -217,35 +230,47 @@
(define (handle-commands) (define (handle-commands)
(log (syslog-level debug) "handling commands")
(call-with-current-continuation (call-with-current-continuation
(lambda (exit) (lambda (exit)
(with-handler (with-handler
(lambda (condition more) (lambda (condition more)
(if (ftpd-quit? condition) (if (ftpd-quit? condition)
(with-handler (begin
(lambda (condition ignore) (log (syslog-level debug) "quitting")
(more)) (with-handler
(lambda () (lambda (condition ignore)
(write-replies) (more))
(exit 'fick-dich-ins-knie))) (lambda ()
(write-replies)
(exit 'fick-dich-ins-knie))))
(more))) (more)))
(lambda () (lambda ()
(log (syslog-level debug)
"starting write-accept-loop")
(let loop () (let loop ()
(write-replies) (write-replies)
(accept-command) (accept-command)
(loop))))))) (loop)))))))
(define (accept-command) (define (accept-command)
(let ((command-line (read-crlf-line-timeout (session-control-input-port) (let* ((timeout-seconds 90)
#f (command-line (read-crlf-line-timeout (session-control-input-port)
90000 ; timeout #f
500))) ; max interval (* 1000 timeout-seconds);timeout
;; (format #t "Command line: ~A~%" command-line) 500))) ; max interval
(cond ((eq? command-line 'timeout) (log (syslog-level debug)
(register-reply! "Command line: ~A"
421 command-line)
"Timeout (900 seconds): closing control connection.") (cond ((eq? command-line 'timeout)
(signal 'ftpd-quit)) (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 (else
(call-with-values (call-with-values
(lambda () (parse-command-line command-line)) (lambda () (parse-command-line command-line))
@ -253,23 +278,35 @@
(handle-command command arg))))))) (handle-command command arg)))))))
(define (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 (call-with-current-continuation
(lambda (escape) (lambda (escape)
(with-handler (with-handler
(lambda (condition more) (lambda (condition more)
(cond (cond
((error? condition) ((error? condition)
(log (syslog-level notice)
"internal error occured: ~S -- replying (451) and escaping"
condition)
(register-reply! 451 (register-reply! 451
(format #f "Internal error: ~S" (format #f "Internal error: ~S"
(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 notice)
"ftpd error occured: ~S -- escaping" ; this may occur more often than you think (??)
(condition-stuff condition))
(escape 'fick-dich-ins-knie)) (escape 'fick-dich-ins-knie))
(else (else
(more)))) (more))))
(lambda () (lambda ()
(with-errno-handler* (with-errno-handler*
(lambda (errno packet) (lambda (errno packet)
(log (syslog-level notice)
"unix error occured: ~S -- replying (451) and escaping"
(car packet))
(register-reply! 451 (register-reply! 451
(format #f "Unix error: ~A." (car packet))) (format #f "Unix error: ~A." (car packet)))
(escape 'fick-dich-ins-knie)) (escape 'fick-dich-ins-knie))
@ -277,6 +314,9 @@
(dispatch-command command arg)))))))) (dispatch-command command arg))))))))
(define (dispatch-command command arg) (define (dispatch-command command arg)
(log (syslog-level debug)
"dispatching command ~S with argument ~S"
command arg)
(cond (cond
((assoc command *command-alist*) ((assoc command *command-alist*)
=> (lambda (pair) => (lambda (pair)
@ -886,7 +926,7 @@
; Version ; Version
(define *ftpd-version* "$Revision: 1.18 $") (define *ftpd-version* "$Revision: 1.19 $")
(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*)))