scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
ftpd.scm
View File

@ -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)
(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)
(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*)))