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

make options LOGFILE and DNS-LOOKUP? thread-safe

This commit is contained in:
interp 2002-09-28 12:38:57 +00:00
parent 6a090fba6b
commit bdf62cbf05
1 changed files with 95 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

166
scheme/ftpd/ftpd.scm
View File

@ -21,8 +21,10 @@
; "FILENAME does not exist" is much better. ; "FILENAME does not exist" is much better.
; - default value for ftpd should be looked up as in ftp.scm ; - default value for ftpd should be looked up as in ftp.scm
(define *logfile* #f) ; file-port to log to like wu-ftpd (analyzable with webalizer) (define-record options
(define *dns-lookup?* #f) ; perform dns-lookup for ips in logfile? logfile
logfile-lock
dns-lookup?)
(define-record session (define-record session
control-input-port control-input-port
@ -41,6 +43,8 @@
(passive-socket #f)) (passive-socket #f))
(define session (make-fluid #f)) (define session (make-fluid #f))
(define options (make-preserved-thread-fluid
(make-options #f #f #f)))
(define (make-fluid-selector selector) (define (make-fluid-selector selector)
(lambda () (selector (fluid session)))) (lambda () (selector (fluid session))))
@ -82,6 +86,15 @@
(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 (make-options-selector selector)
(lambda () (selector (thread-fluid options))))
;(define (make-options-setter setter)
; (lambda (value)
; (setter (thread-fluid options))))
(define options-logfile (make-options-selector options:logfile))
(define options-logfile-lock (make-options-selector options:logfile-lock))
(define options-dns-lookup? (make-options-selector options:dns-lookup?))
;;; LOG ------------------------------------------------------- ;;; LOG -------------------------------------------------------
(define (log level format-message . args) (define (log level format-message . args)
@ -129,17 +142,16 @@
; 13 authenticated user id (if available, '*' otherwise) ; 13 authenticated user id (if available, '*' otherwise)
; ;
(define file-log (define file-log
(let ((file-log-lock (make-lock)) (let ((maybe-dns-lookup (lambda (ip)
(maybe-dns-lookup (lambda (ip) (if (options-dns-lookup?)
(if *dns-lookup?*
(or (dns-lookup-ip ip) (or (dns-lookup-ip ip)
ip) ip))
ip)))) ip)))
(lambda (start-transfer-seconds info full-path direction) (lambda (start-transfer-seconds info full-path direction)
(if *logfile* (if (options-logfile)
(begin (begin
(obtain-lock file-log-lock) (obtain-lock (options-logfile-lock))
(format *logfile* "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%" (format (options-logfile) "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%"
(format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) ; current date and time (format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) ; current date and time
(- (current-seconds) start-transfer-seconds) ; transfer time in secs (- (current-seconds) start-transfer-seconds) ; transfer time in secs
(maybe-dns-lookup (maybe-dns-lookup
@ -160,8 +172,19 @@
; authentication mode ; authentication mode
; authenticated user id' ; authenticated user id'
) )
(force-output *logfile*) (force-output (options-logfile))
(release-lock file-log-lock)))))) (release-lock (options-logfile-lock)))))))
(define (open-logfile logfile)
(with-errno-handler
((errno packet)
(else
(format (current-error-port)
"[ftpd] Warning: Unable to write logs to ~S. Logging is now made to (current-error-port).~%[ftpd] (To disable logging at all, either leave the logfile argument or give #f as logfile)~%")
(current-error-port)))
(and logfile
(open-output-file logfile
(bitwise-ior open/create open/append)))))
;;; CONVERTERS ------------------------------------------------ ;;; CONVERTERS ------------------------------------------------
(define (protocol-family->string protocol-family) (define (protocol-family->string protocol-family)
@ -185,39 +208,39 @@
;;; ftpd ------------------------------------------------------- ;;; ftpd -------------------------------------------------------
(define (ftpd anonymous-home . maybe-args) (define (ftpd anonymous-home . maybe-args)
(let-optionals (let-optionals maybe-args
maybe-args ((port 21)
((port 21) (logfile #f)
(logfile #f) (dns-lookup? #f))
(dns-lookup? #f))
(if logfile (let-thread-fluid options
(set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append)))) (make-options (open-logfile logfile)
(if dns-lookup? (make-lock)
(set! *dns-lookup?* #t) (and dns-lookup?))
(set! *dns-lookup?* #f)) (lambda ()
(with-syslog-destination
"ftpd" (with-syslog-destination
#f "ftpd"
#f #f
#f #f
(lambda () #f
(log (syslog-level notice) (lambda ()
"starting daemon on port ~D with ~S as anonymous home and logfile ~S" (log (syslog-level notice)
port (expand-file-name anonymous-home (cwd)) logfile) "starting daemon on port ~D with ~S as anonymous home and logfile ~S"
port (expand-file-name anonymous-home (cwd)) logfile)
(bind-listen-accept-loop (bind-listen-accept-loop
protocol-family/internet protocol-family/internet
(lambda (socket address) (lambda (socket address)
(let ((remote-address (socket-address->string address))) (let ((remote-address (socket-address->string address)))
(set-ftp-socket-options! socket) (set-ftp-socket-options! socket)
(fork-thread (fork-thread
(spawn-to-handle-connection socket (spawn-to-handle-connection socket
address address
anonymous-home anonymous-home
port port
remote-address)))) remote-address))))
port))))) port)))))))
(define (spawn-to-handle-connection socket address anonymous-home port remote-address) (define (spawn-to-handle-connection socket address anonymous-home port remote-address)
(lambda () (lambda ()
@ -264,29 +287,30 @@
"closing socket ~S" socket-string) "closing socket ~S" socket-string)
(close-socket socket)))))))))) (close-socket socket))))))))))
(define (ftpd-inetd anonymous-home . maybe-logfile) (define (ftpd-inetd anonymous-home . maybe-args)
(let ((logfile (optional maybe-logfile))) (let-optionals maybe-args
(with-errno-handler ((logfile #f)
((errno packet) (dns-lookup? #f))
(else
(format (current-error-port) "[ftpd] Warning: Unable to write logs to ~S. Logging is now made to (current-error-port).~%[ftpd] (To disable logging at all, either leave the logfile argument or give #f as logfile)~%") (let-thread-fluid options
(set! *logfile* (current-error-port)))) (make-options (open-logfile logfile)
(if logfile (make-lock)
(set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append)))))) (and dns-lookup?))
(lambda ()
(with-syslog-destination (with-syslog-destination
"ftpd" "ftpd"
#f #f
#f #f
#f #f
(lambda () (lambda ()
(log (syslog-level notice) (log (syslog-level notice)
"starting ftpd from inetd" "starting ftpd from inetd"
(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
@ -1221,7 +1245,7 @@
; Version ; Version
(define *ftpd-version* "$Revision: 1.7 $") (define *ftpd-version* "$Revision: 1.8 $")
(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*)))
@ -1265,8 +1289,8 @@
; Utilities ; Utilities
(define (optional maybe-arg default-exp) ;(define (optional maybe-arg default-exp)
(cond ; (cond
((null? maybe-arg) default-exp) ; ((null? maybe-arg) default-exp)
((null? (cdr maybe-arg)) (car maybe-arg)) ; ((null? (cdr maybe-arg)) (car maybe-arg))
(else (error "too many optional arguments" maybe-arg)))) ; (else (error "too many optional arguments" maybe-arg))))