added more syslog messages
This commit is contained in:
parent
5b666fb2e4
commit
747f3cb054
70
ftpd.scm
70
ftpd.scm
|
@ -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)
|
|
||||||
(syslog level
|
|
||||||
(apply format #f format-message args))))
|
|
||||||
|
|
||||||
|
;;; LOG -------------------------------------------------------
|
||||||
|
(define (log level format-message . args)
|
||||||
|
(syslog level
|
||||||
|
(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)
|
||||||
|
(begin
|
||||||
|
(log (syslog-level debug) "quitting")
|
||||||
(with-handler
|
(with-handler
|
||||||
(lambda (condition ignore)
|
(lambda (condition ignore)
|
||||||
(more))
|
(more))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(write-replies)
|
(write-replies)
|
||||||
(exit 'fick-dich-ins-knie)))
|
(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)
|
||||||
|
(command-line (read-crlf-line-timeout (session-control-input-port)
|
||||||
#f
|
#f
|
||||||
90000 ; timeout
|
(* 1000 timeout-seconds);timeout
|
||||||
500))) ; max interval
|
500))) ; max interval
|
||||||
;; (format #t "Command line: ~A~%" command-line)
|
(log (syslog-level debug)
|
||||||
|
"Command line: ~A"
|
||||||
|
command-line)
|
||||||
(cond ((eq? command-line 'timeout)
|
(cond ((eq? command-line 'timeout)
|
||||||
|
(log (syslog-level debug)
|
||||||
|
"hit timelimit (~D seconds) -- closing control connection."
|
||||||
|
timeout-seconds)
|
||||||
(register-reply!
|
(register-reply!
|
||||||
421
|
421
|
||||||
"Timeout (900 seconds): closing control connection.")
|
(format #f "Timeout (~D seconds): closing control connection."
|
||||||
(signal 'ftpd-quit))
|
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*)))
|
||||||
|
|
Loading…
Reference in New Issue