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

using WITH-SYSLOG-DESTINATION

This commit is contained in:
interp 2001-06-26 13:15:56 +00:00
parent 1e164e08b2
commit 5b666fb2e4
1 changed files with 75 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
ftpd.scm
View File

@ -72,10 +72,7 @@
(define log (define log
(lambda (level format-message . args) (lambda (level format-message . args)
(syslog level (syslog level
(apply format #f format-message args) (apply format #f format-message args))))
(format "ftpd[~D]" (thread-uid (current-thread)))
#f
(syslog-facility daemon))))
(define (protocol-family->string protocol-family) (define (protocol-family->string protocol-family)
(cond ((= protocol-family protocol-family/unspecified) (cond ((= protocol-family protocol-family/unspecified)
@ -104,68 +101,81 @@
(define (ftpd anonymous-home . maybe-port) (define (ftpd anonymous-home . maybe-port)
(let ((port (optional maybe-port 21))) (let ((port (optional maybe-port 21)))
(log (syslog-level notice) (with-syslog-destination
"starting on port ~D with ~S as anonymous home" "ftpd"
port (expand-file-name anonymous-home (cwd))) (syslog-options log-pid)
(bind-listen-accept-loop (syslog-facility daemon)
protocol-family/internet syslog-mask-all
(lambda (socket address) (lambda ()
(log (syslog-level info) (log (syslog-level notice)
"new connection with ~S" "starting on port ~D with ~S as anonymous home"
(socket-address->string address) port (expand-file-name anonymous-home (cwd)))
(bind-listen-accept-loop
protocol-family/internet
(lambda (socket address)
(log (syslog-level debug)
"got connection with socket ~S and address ~S"
(socket->string socket)
(socket-address->string address))
(set-ftp-socket-options! socket)
(spawn
(lambda ()
(handle-connection (socket:inport socket)
(socket:outport socket)
(file-name-as-directory anonymous-home))
(call-with-current-continuation
(lambda (exit)
(with-errno-handler*
(lambda (errno packet)
(cond
;; I dunno why SHUTDOWN-SOCKET can die this way, but it
;; can and does
((= 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)
"shutting down socket ~S"
(socket->string socket))
(shutdown-socket socket shutdown/sends+receives)))))
(log (syslog-level info) (log (syslog-level info)
"closing socket") "new connection with ~S"
(close-socket socket)) (socket-address->string address))
(socket-address->string address)))) ; use remote address as thread-name
port))) (log (syslog-level debug)
"got connection with socket ~S and address ~S"
(socket->string socket)
(socket-address->string address))
(set-ftp-socket-options! socket)
(spawn
(lambda ()
(handle-connection (socket:inport socket)
(socket:outport socket)
(file-name-as-directory anonymous-home))
(call-with-current-continuation
(lambda (exit)
(with-errno-handler*
(lambda (errno packet)
(cond
;; I dunno why SHUTDOWN-SOCKET can die this way, but it
;; can and does
((= 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)
"shutting down socket ~S"
(socket->string socket))
(shutdown-socket socket shutdown/sends+receives)))))
(log (syslog-level info)
"closing socket")
(close-socket socket))
(socket-address->string address))) ; use remote address as thread-name
port)))))
(define (ftpd-inetd anonymous-home) (define (ftpd-inetd anonymous-home)
(log (syslog-level info) (with-syslog-destination
"new connection on current input- and output-port with ~S as anonymous home" "ftpd"
(expand-file-name anonymous-home (cwd))) (syslog-option log-pid)
(syslog-facility daemon)
#f
(lambda ()
(log (syslog-level info)
"new connection on current input- and output-port with ~S as anonymous home"
(expand-file-name anonymous-home (cwd)))
(log (syslog-level debug) (log (syslog-level debug)
"new connection on current input-port ~A and current output-port ~A with ~S as anonymous home" "new connection on current input-port ~A and current output-port ~A with ~S as anonymous home"
(current-input-port) (current-input-port)
(current-output-port) (current-output-port)
(expand-file-name anonymous-home (cwd))) (expand-file-name anonymous-home (cwd)))
(handle-connection (current-input-port) (handle-connection (current-input-port)
(current-output-port) (current-output-port)
(file-name-as-directory anonymous-home))) (file-name-as-directory anonymous-home)))))
(define (set-ftp-socket-options! socket) (define (set-ftp-socket-options! socket)
;; If the client closes the connection, we won't lose when we try to ;; If the client closes the connection, we won't lose when we try to
@ -876,7 +886,7 @@
; Version ; Version
(define *ftpd-version* "$Revision: 1.17 $") (define *ftpd-version* "$Revision: 1.18 $")
(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*)))