make options LOGFILE and DNS-LOOKUP? thread-safe
This commit is contained in:
interp
parent
6a090fba6b
commit
bdf62cbf05
|
|
@ -21,8 +21,10 @@
|
|||
; "FILENAME does not exist" is much better.
|
||||
; - 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 *dns-lookup?* #f) ; perform dns-lookup for ips in logfile?
|
||||
(define-record options
|
||||
logfile
|
||||
logfile-lock
|
||||
dns-lookup?)
|
||||
|
||||
(define-record session
|
||||
control-input-port
|
||||
|
|
@ -41,6 +43,8 @@
|
|||
(passive-socket #f))
|
||||
|
||||
(define session (make-fluid #f))
|
||||
(define options (make-preserved-thread-fluid
|
||||
(make-options #f #f #f)))
|
||||
|
||||
(define (make-fluid-selector selector)
|
||||
(lambda () (selector (fluid session))))
|
||||
|
|
@ -82,6 +86,15 @@
|
|||
(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 (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 -------------------------------------------------------
|
||||
(define (log level format-message . args)
|
||||
|
|
@ -129,17 +142,16 @@
|
|||
; 13 authenticated user id (if available, '*' otherwise)
|
||||
;
|
||||
(define file-log
|
||||
(let ((file-log-lock (make-lock))
|
||||
(maybe-dns-lookup (lambda (ip)
|
||||
(if *dns-lookup?*
|
||||
(let ((maybe-dns-lookup (lambda (ip)
|
||||
(if (options-dns-lookup?)
|
||||
(or (dns-lookup-ip ip)
|
||||
ip)
|
||||
ip))))
|
||||
ip))
|
||||
ip)))
|
||||
(lambda (start-transfer-seconds info full-path direction)
|
||||
(if *logfile*
|
||||
(if (options-logfile)
|
||||
(begin
|
||||
(obtain-lock file-log-lock)
|
||||
(format *logfile* "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%"
|
||||
(obtain-lock (options-logfile-lock))
|
||||
(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
|
||||
(- (current-seconds) start-transfer-seconds) ; transfer time in secs
|
||||
(maybe-dns-lookup
|
||||
|
|
@ -160,8 +172,19 @@
|
|||
; authentication mode
|
||||
; authenticated user id'
|
||||
)
|
||||
(force-output *logfile*)
|
||||
(release-lock file-log-lock))))))
|
||||
(force-output (options-logfile))
|
||||
(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 ------------------------------------------------
|
||||
(define (protocol-family->string protocol-family)
|
||||
|
|
@ -185,39 +208,39 @@
|
|||
;;; ftpd -------------------------------------------------------
|
||||
|
||||
(define (ftpd anonymous-home . maybe-args)
|
||||
(let-optionals
|
||||
maybe-args
|
||||
((port 21)
|
||||
(logfile #f)
|
||||
(dns-lookup? #f))
|
||||
(let-optionals maybe-args
|
||||
((port 21)
|
||||
(logfile #f)
|
||||
(dns-lookup? #f))
|
||||
|
||||
(if logfile
|
||||
(set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append))))
|
||||
(if dns-lookup?
|
||||
(set! *dns-lookup?* #t)
|
||||
(set! *dns-lookup?* #f))
|
||||
(with-syslog-destination
|
||||
"ftpd"
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
(lambda ()
|
||||
(log (syslog-level notice)
|
||||
"starting daemon on port ~D with ~S as anonymous home and logfile ~S"
|
||||
port (expand-file-name anonymous-home (cwd)) logfile)
|
||||
(let-thread-fluid options
|
||||
(make-options (open-logfile logfile)
|
||||
(make-lock)
|
||||
(and dns-lookup?))
|
||||
(lambda ()
|
||||
|
||||
(with-syslog-destination
|
||||
"ftpd"
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
(lambda ()
|
||||
(log (syslog-level notice)
|
||||
"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
|
||||
protocol-family/internet
|
||||
(lambda (socket address)
|
||||
(let ((remote-address (socket-address->string address)))
|
||||
(set-ftp-socket-options! socket)
|
||||
(fork-thread
|
||||
(spawn-to-handle-connection socket
|
||||
address
|
||||
anonymous-home
|
||||
port
|
||||
remote-address))))
|
||||
port)))))
|
||||
(bind-listen-accept-loop
|
||||
protocol-family/internet
|
||||
(lambda (socket address)
|
||||
(let ((remote-address (socket-address->string address)))
|
||||
(set-ftp-socket-options! socket)
|
||||
(fork-thread
|
||||
(spawn-to-handle-connection socket
|
||||
address
|
||||
anonymous-home
|
||||
port
|
||||
remote-address))))
|
||||
port)))))))
|
||||
|
||||
(define (spawn-to-handle-connection socket address anonymous-home port remote-address)
|
||||
(lambda ()
|
||||
|
|
@ -264,29 +287,30 @@
|
|||
"closing socket ~S" socket-string)
|
||||
(close-socket socket))))))))))
|
||||
|
||||
(define (ftpd-inetd anonymous-home . maybe-logfile)
|
||||
(let ((logfile (optional maybe-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)~%")
|
||||
(set! *logfile* (current-error-port))))
|
||||
(if logfile
|
||||
(set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append))))))
|
||||
(define (ftpd-inetd anonymous-home . maybe-args)
|
||||
(let-optionals maybe-args
|
||||
((logfile #f)
|
||||
(dns-lookup? #f))
|
||||
|
||||
(let-thread-fluid options
|
||||
(make-options (open-logfile logfile)
|
||||
(make-lock)
|
||||
(and dns-lookup?))
|
||||
(lambda ()
|
||||
|
||||
(with-syslog-destination
|
||||
"ftpd"
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
(lambda ()
|
||||
(log (syslog-level notice)
|
||||
"starting ftpd from inetd"
|
||||
(expand-file-name anonymous-home (cwd)))
|
||||
|
||||
(handle-connection (current-input-port)
|
||||
(current-output-port)
|
||||
(file-name-as-directory anonymous-home)))))
|
||||
(with-syslog-destination
|
||||
"ftpd"
|
||||
#f
|
||||
#f
|
||||
#f
|
||||
(lambda ()
|
||||
(log (syslog-level notice)
|
||||
"starting ftpd from inetd"
|
||||
(expand-file-name anonymous-home (cwd)))
|
||||
|
||||
(handle-connection (current-input-port)
|
||||
(current-output-port)
|
||||
(file-name-as-directory anonymous-home))))))))
|
||||
|
||||
(define (set-ftp-socket-options! socket)
|
||||
;; If the client closes the connection, we won't lose when we try to
|
||||
|
|
@ -1221,7 +1245,7 @@
|
|||
|
||||
; Version
|
||||
|
||||
(define *ftpd-version* "$Revision: 1.7 $")
|
||||
(define *ftpd-version* "$Revision: 1.8 $")
|
||||
|
||||
(define (copy-port->port-binary input-port output-port)
|
||||
(let ((buffer (make-string *window-size*)))
|
||||
|
|
@ -1265,8 +1289,8 @@
|
|||
|
||||
; Utilities
|
||||
|
||||
(define (optional maybe-arg default-exp)
|
||||
(cond
|
||||
((null? maybe-arg) default-exp)
|
||||
((null? (cdr maybe-arg)) (car maybe-arg))
|
||||
(else (error "too many optional arguments" maybe-arg))))
|
||||
;(define (optional maybe-arg default-exp)
|
||||
; (cond
|
||||
; ((null? maybe-arg) default-exp)
|
||||
; ((null? (cdr maybe-arg)) (car maybe-arg))
|
||||
; (else (error "too many optional arguments" maybe-arg))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue