added more syslog messages
This commit is contained in:
parent
5b666fb2e4
commit
747f3cb054
90
ftpd.scm
90
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*)))
|
||||
|
|
Loading…
Reference in New Issue