diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm index c6e258d..f18202a 100644 --- a/scheme/ftpd/ftpd.scm +++ b/scheme/ftpd/ftpd.scm @@ -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))))