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

Clean up logging in ftpd: 

- hold relevant data in new SERVER-STATE fluid
- specify log destination as a port, not a file
This commit is contained in:
sperber 2003-01-28 10:49:45 +00:00
parent a44ab62741
commit eb20aec688
3 changed files with 83 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
doc/latex/ftpd.tex
View File

@ -1,4 +1,4 @@
\chapter{FTP server}\label{cha:ftpd} \chapter{FTP Server}\label{cha:ftpd}
The \ex{ftpd} structure contains a complete anonymous ftp server. The \ex{ftpd} structure contains a complete anonymous ftp server.
@ -38,10 +38,10 @@ the optional second one. Here they are:
represented as a list of strings, one for each line of output. represented as a list of strings, one for each line of output.
\end{desc} \end{desc}
\defun{with-logfile}{file-name [options]}{options} \defun{with-log-port}{output-port [options]}{options}
\begin{desc} \begin{desc}
If this is non-\sharpf, ex{ftpd} makes a log entry for each file If this is non-\sharpf, ex{ftpd} outputs a log entry for each file
sent or retrieved in \var{file-name}. Defaults to \sharpf. sent or retrieved on \var{output-port}. Defaults to \sharpf.
\end{desc} \end{desc}
\defun{with-dns-lookup?}{boolean [options]}{options} \defun{with-dns-lookup?}{boolean [options]}{options}

162
scheme/ftpd/ftpd.scm
View File

@ -23,12 +23,12 @@
(define-record-type ftpd-options :ftpd-options (define-record-type ftpd-options :ftpd-options
(really-make-ftpd-options port anonymous-home banner (really-make-ftpd-options port anonymous-home banner
logfile dns-lookup?) log-port dns-lookup?)
ftpd-options? ftpd-options?
(port ftpd-options-port set-ftpd-options-port!) (port ftpd-options-port set-ftpd-options-port!)
(anonymous-home ftpd-options-anonymous-home set-ftpd-options-anonymous-home!) (anonymous-home ftpd-options-anonymous-home set-ftpd-options-anonymous-home!)
(banner ftpd-options-banner set-ftpd-options-banner!) (banner ftpd-options-banner set-ftpd-options-banner!)
(logfile ftpd-options-logfile set-ftpd-options-logfile!) (log-port ftpd-options-log-port set-ftpd-options-log-port!)
(dns-lookup? ftpd-options-dns-lookup? set-ftpd-options-dns-lookup?!)) (dns-lookup? ftpd-options-dns-lookup? set-ftpd-options-dns-lookup?!))
(define (make-default-ftpd-options) (define (make-default-ftpd-options)
@ -45,7 +45,7 @@
(really-make-ftpd-options (ftpd-options-port options) (really-make-ftpd-options (ftpd-options-port options)
(ftpd-options-anonymous-home options) (ftpd-options-anonymous-home options)
(ftpd-options-banner options) (ftpd-options-banner options)
(ftpd-options-logfile options) (ftpd-options-log-port options)
(ftpd-options-dns-lookup? options))) (ftpd-options-dns-lookup? options)))
(define (make-ftpd-options-transformer set-option!) (define (make-ftpd-options-transformer set-option!)
@ -62,8 +62,8 @@
(make-ftpd-options-transformer set-ftpd-options-anonymous-home!)) (make-ftpd-options-transformer set-ftpd-options-anonymous-home!))
(define with-banner (define with-banner
(make-ftpd-options-transformer set-ftpd-options-banner!)) (make-ftpd-options-transformer set-ftpd-options-banner!))
(define with-logfile (define with-log-port
(make-ftpd-options-transformer set-ftpd-options-logfile!)) (make-ftpd-options-transformer set-ftpd-options-log-port!))
(define with-dns-lookup? (define with-dns-lookup?
(make-ftpd-options-transformer set-ftpd-options-dns-lookup?!)) (make-ftpd-options-transformer set-ftpd-options-dns-lookup?!))
@ -77,10 +77,18 @@
(loop (transformer value options) (loop (transformer value options)
(cddr stuff)))))) (cddr stuff))))))
(define-record-type server-state :server-state
(really-make-server-state log-lock log-port)
server-state?
(log-lock server-state-log-lock)
(log-port server-state-log-port))
(define (make-server-state log-port)
(really-make-server-state (make-lock) log-port))
(define-record-type session :session (define-record-type session :session
(really-make-session control-input-port (really-make-session control-input-port
control-output-port control-output-port
logfile-lock
logged-in? logged-in?
authenticated? authenticated?
anonymous? anonymous?
@ -91,14 +99,12 @@
reply-code reply-code
type type
data-socket data-socket
passive-socket passive-socket)
maybe-log-port)
session? session?
(control-input-port session-control-input-port (control-input-port session-control-input-port
set-session-control-input-port!) set-session-control-input-port!)
(control-output-port session-control-output-port (control-output-port session-control-output-port
set-session-control-output-port!) set-session-control-output-port!)
(logfile-lock session-logfile-lock)
(logged-in? session-logged-in? (logged-in? session-logged-in?
set-session-logged-in?!) set-session-logged-in?!)
(authenticated? session-authenticated? (authenticated? session-authenticated?
@ -112,7 +118,7 @@
(to-be-renamed session-to-be-renamed (to-be-renamed session-to-be-renamed
set-session-to-be-renamed!) set-session-to-be-renamed!)
(replies session-replies (replies session-replies
set-session-replies!) set-session-replies!)
(reply-code session-reply-code (reply-code session-reply-code
set-session-reply-code!) set-session-reply-code!)
(type session-type (type session-type
@ -120,13 +126,10 @@
(data-socket session-data-socket (data-socket session-data-socket
set-session-data-socket!) set-session-data-socket!)
(passive-socket session-passive-socket (passive-socket session-passive-socket
set-session-passive-socket!) set-session-passive-socket!))
(maybe-log-port session-maybe-log-port
set-session-maybe-log-port!))
(define (make-session input-port output-port maybe-log-port) (define (make-session input-port output-port)
(really-make-session input-port output-port (really-make-session input-port output-port
(make-lock)
#f ; logged-in? #f ; logged-in?
#f ; autenticated? #f ; autenticated?
#f ; anonymous? #f ; anonymous?
@ -138,10 +141,10 @@
'ascii ; type 'ascii ; type
#f ; data-socket #f ; data-socket
#f ; passive-socket #f ; passive-socket
maybe-log-port
)) ))
(define session (make-fluid #f)) (define session (make-fluid #f))
(define server-state (make-fluid #f))
(define options (make-fluid #f)) (define options (make-fluid #f))
(define (make-session-selector selector) (define (make-session-selector selector)
@ -156,8 +159,6 @@
(make-session-selector session-control-input-port)) (make-session-selector session-control-input-port))
(define the-session-control-output-port (define the-session-control-output-port
(make-session-selector session-control-output-port)) (make-session-selector session-control-output-port))
(define the-session-logfile-lock
(make-session-selector session-logfile-lock))
(define the-session-logged-in? (make-session-selector session-logged-in?)) (define the-session-logged-in? (make-session-selector session-logged-in?))
(define the-session-authenticated? (make-session-selector session-authenticated?)) (define the-session-authenticated? (make-session-selector session-authenticated?))
@ -170,7 +171,6 @@
(define the-session-type (make-session-selector session-type)) (define the-session-type (make-session-selector session-type))
(define the-session-data-socket (make-session-selector session-data-socket)) (define the-session-data-socket (make-session-selector session-data-socket))
(define the-session-passive-socket (make-session-selector session-passive-socket)) (define the-session-passive-socket (make-session-selector session-passive-socket))
(define the-session-maybe-log-port (make-session-selector session-maybe-log-port))
(define set-the-session-control-input-port! (define set-the-session-control-input-port!
(make-session-modifier set-session-control-input-port!)) (make-session-modifier set-session-control-input-port!))
@ -198,8 +198,19 @@
(make-session-modifier set-session-data-socket!)) (make-session-modifier set-session-data-socket!))
(define set-the-session-passive-socket! (define set-the-session-passive-socket!
(make-session-modifier set-session-passive-socket!)) (make-session-modifier set-session-passive-socket!))
(define set-the-session-maybe-log-port!
(make-session-modifier set-session-maybe-log-port!)) (define (make-server-state-selector selector)
(lambda ()
(selector (fluid server-state))))
(define (make-server-state-modifier setter)
(lambda (value)
(setter (fluid server-state) value)))
(define the-server-state-log-lock
(make-server-state-selector server-state-log-lock))
(define the-server-state-log-port
(make-server-state-selector server-state-log-port))
(define (make-ftpd-options-selector selector) (define (make-ftpd-options-selector selector)
(lambda () (lambda ()
@ -211,16 +222,16 @@
(make-ftpd-options-selector ftpd-options-anonymous-home)) (make-ftpd-options-selector ftpd-options-anonymous-home))
(define the-ftpd-options-banner (define the-ftpd-options-banner
(make-ftpd-options-selector ftpd-options-banner)) (make-ftpd-options-selector ftpd-options-banner))
(define the-ftpd-options-logfile (define the-ftpd-options-log-port
(make-ftpd-options-selector ftpd-options-logfile)) (make-ftpd-options-selector ftpd-options-log-port))
(define the-ftpd-options-dns-lookup? (define the-ftpd-options-dns-lookup?
(make-ftpd-options-selector ftpd-options-dns-lookup?)) (make-ftpd-options-selector ftpd-options-dns-lookup?))
;;; LOG ------------------------------------------------------- ;;; LOG -------------------------------------------------------
(define (log level format-message . args) (define (log level format-message . args)
(syslog level (syslog level
(apply format #f (string-append "(thread ~D) " format-message) (apply format #f (string-append "(thread ~D) " format-message)
(thread-uid (current-thread)) args))) (thread-uid (current-thread)) args)))
(define (log-command level command-name . argument) (define (log-command level command-name . argument)
(if (null? argument) (if (null? argument)
@ -228,7 +239,7 @@
(if (not (null? (cdr argument))) (if (not (null? (cdr argument)))
(log level "handling ~A command with argument ~S" (log level "handling ~A command with argument ~S"
command-name argument) command-name argument)
(log level "handling ~A command with argument ~S" ; does this ever happen? (log level "handling ~A command with argument ~S" ; does this ever happen?
command-name (car argument))))) command-name (car argument)))))
;; Extended logging like wu.ftpd: ;; Extended logging like wu.ftpd:
@ -261,53 +272,35 @@
; 1 RFC931 Authentication ; 1 RFC931 Authentication
; 13 authenticated user id (if available, '*' otherwise) ; 13 authenticated user id (if available, '*' otherwise)
; ;
(define file-log (define (file-log start-transfer-seconds info full-path direction)
(let ((maybe-dns-lookup (lambda (ip) (if (the-server-state-log-port)
(if (the-ftpd-options-dns-lookup?) (begin
(or (dns-lookup-ip ip) (obtain-lock (the-server-state-log-lock))
ip)) (format (the-server-state-log-port)
ip))) "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%"
(lambda (start-transfer-seconds info full-path direction) (format-date "~a ~b ~d ~H:~M:~S ~Y" (date))
(if (the-session-maybe-log-port) (- (current-seconds) start-transfer-seconds)
(begin (maybe-dns-lookup
(obtain-lock (the-session-logfile-lock)) (socket-address->string
(format (the-session-maybe-log-port) (socket-remote-address (the-session-data-socket)) #f))
"~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%" (file-info:size info)
(format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) ; current date and time (string-map (lambda (c)
(- (current-seconds) start-transfer-seconds) ; transfer time in secs (if (eq? c #\space) #\_ c))
(maybe-dns-lookup full-path)
(socket-address->string (case (the-session-type)
(socket-remote-address (the-session-data-socket)) #f)) ; remote host ip ((ascii) "a")
(file-info:size info) ; file size in bytes ((image) "b")
(string-map (lambda (c) (else "?"))
(if (eq? c #\space) #\_ c)) direction)
full-path) ; name of file (spaces replaced by "_") (force-output (the-server-state-log-port))
(case (the-session-type) (release-lock (the-server-state-log-lock)))))
((ascii) "a")
((image) "b") (define (maybe-dns-lookup ip)
(else "?")) ; transfer type (if (the-ftpd-options-dns-lookup?)
direction ; incoming / outgoing file (or (dns-lookup-ip ip)
; anonymous access ip)
; password (no password given) ip))
; service name
; authentication mode
; authenticated user id'
)
(force-output (the-session-maybe-log-port))
(release-lock (the-session-logfile-lock)))))))
(define (maybe-open-logfile 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)~%"
maybe-logfile)
(current-error-port)))
(and maybe-logfile
(open-output-file maybe-logfile
(bitwise-ior open/create open/append)))))
;;; CONVERTERS ------------------------------------------------ ;;; CONVERTERS ------------------------------------------------
(define (protocol-family->string protocol-family) (define (protocol-family->string protocol-family)
(cond ((= protocol-family protocol-family/unspecified) (cond ((= protocol-family protocol-family/unspecified)
@ -338,12 +331,11 @@
#f #f
(lambda () (lambda ()
(log (syslog-level notice) (log (syslog-level notice)
"starting daemon on port ~D with ~S as anonymous home and logfile ~S" "starting daemon on port ~D with ~S as anonymous home"
(ftpd-options-port ftpd-options) (ftpd-options-port ftpd-options)
(expand-file-name (ftpd-options-anonymous-home ftpd-options) (expand-file-name (ftpd-options-anonymous-home ftpd-options)
(cwd)) (cwd)))
(ftpd-options-logfile ftpd-options)) (let ((the-server-state (make-server-state (ftpd-options-log-port ftpd-options))))
(let ((maybe-log-port (maybe-open-logfile (ftpd-options-logfile ftpd-options))))
(bind-listen-accept-loop (bind-listen-accept-loop
protocol-family/internet protocol-family/internet
(lambda (socket address) (lambda (socket address)
@ -355,10 +347,11 @@
socket socket
address address
remote-address remote-address
maybe-log-port))))) the-server-state)))))
(ftpd-options-port ftpd-options)))))) (ftpd-options-port ftpd-options))))))
(define (handle-connection-encapsulated ftpd-options socket address remote-address maybe-log-port) (define (handle-connection-encapsulated ftpd-options socket address remote-address
the-server-state)
(call-with-current-continuation (call-with-current-continuation
(lambda (exit) (lambda (exit)
(with-errno-handler* (with-errno-handler*
@ -382,7 +375,7 @@
(handle-connection ftpd-options (handle-connection ftpd-options
(socket:inport socket) (socket:inport socket)
(socket:outport socket) (socket:outport socket)
maybe-log-port)) the-server-state))
(lambda () (lambda ()
(log (syslog-level debug) (log (syslog-level debug)
"shutting down socket ~S" "shutting down socket ~S"
@ -417,7 +410,7 @@
(handle-connection ftpd-options (handle-connection ftpd-options
(current-input-port) (current-input-port)
(current-output-port) (current-output-port)
(maybe-open-logfile (ftpd-options-logfile ftpd-options)))))) (make-server-state (ftpd-options-log-port ftpd-options))))))
(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
@ -431,7 +424,7 @@
(set-socket-option socket level/socket socket/oob-inline #t)) (set-socket-option socket level/socket socket/oob-inline #t))
(define (handle-connection ftpd-options input-port output-port maybe-log-port) (define (handle-connection ftpd-options input-port output-port the-server-state)
(log (syslog-level debug) (log (syslog-level debug)
"handling connection with input port ~A, output port ~A" "handling connection with input port ~A, output port ~A"
input-port input-port
@ -447,7 +440,8 @@
(escape 'fick-dich-ins-knie)) (escape 'fick-dich-ins-knie))
(lambda () (lambda ()
(let-fluids (let-fluids
session (make-session input-port output-port maybe-log-port) session (make-session input-port output-port)
server-state the-server-state
options ftpd-options options ftpd-options
(lambda () (lambda ()
(display-banner) (display-banner)
@ -1305,7 +1299,7 @@
(define (signal-error! code message) (define (signal-error! code message)
(replace-reply! code message) (replace-reply! code message)
(signal 'ftpd-error)) (signal 'ftpd-error code message))
(define (register-reply! code . messages) (define (register-reply! code . messages)
(if (the-session-reply-code) (if (the-session-reply-code)

2
scheme/packages.scm
View File

@ -203,7 +203,7 @@
;; FTP server ;; FTP server
(define-interface ftpd-interface (define-interface ftpd-interface
(export with-port with-anonymous-home with-banner with-logfile with-dns-lookup? (export with-port with-anonymous-home with-banner with-log-port with-dns-lookup?
make-ftpd-options make-ftpd-options
ftpd ftpd
ftpd-inetd)) ftpd-inetd))