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
parent
a44ab62741
commit
eb20aec688
|
|
@ -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.
|
||||
|
||||
|
|
@ -38,10 +38,10 @@ the optional second one. Here they are:
|
|||
represented as a list of strings, one for each line of output.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-logfile}{file-name [options]}{options}
|
||||
\defun{with-log-port}{output-port [options]}{options}
|
||||
\begin{desc}
|
||||
If this is non-\sharpf, ex{ftpd} makes a log entry for each file
|
||||
sent or retrieved in \var{file-name}. Defaults to \sharpf.
|
||||
If this is non-\sharpf, ex{ftpd} outputs a log entry for each file
|
||||
sent or retrieved on \var{output-port}. Defaults to \sharpf.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-dns-lookup?}{boolean [options]}{options}
|
||||
|
|
|
|||
|
|
@ -23,12 +23,12 @@
|
|||
|
||||
(define-record-type ftpd-options :ftpd-options
|
||||
(really-make-ftpd-options port anonymous-home banner
|
||||
logfile dns-lookup?)
|
||||
log-port dns-lookup?)
|
||||
ftpd-options?
|
||||
(port ftpd-options-port set-ftpd-options-port!)
|
||||
(anonymous-home ftpd-options-anonymous-home set-ftpd-options-anonymous-home!)
|
||||
(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?!))
|
||||
|
||||
(define (make-default-ftpd-options)
|
||||
|
|
@ -45,7 +45,7 @@
|
|||
(really-make-ftpd-options (ftpd-options-port options)
|
||||
(ftpd-options-anonymous-home options)
|
||||
(ftpd-options-banner options)
|
||||
(ftpd-options-logfile options)
|
||||
(ftpd-options-log-port options)
|
||||
(ftpd-options-dns-lookup? options)))
|
||||
|
||||
(define (make-ftpd-options-transformer set-option!)
|
||||
|
|
@ -62,8 +62,8 @@
|
|||
(make-ftpd-options-transformer set-ftpd-options-anonymous-home!))
|
||||
(define with-banner
|
||||
(make-ftpd-options-transformer set-ftpd-options-banner!))
|
||||
(define with-logfile
|
||||
(make-ftpd-options-transformer set-ftpd-options-logfile!))
|
||||
(define with-log-port
|
||||
(make-ftpd-options-transformer set-ftpd-options-log-port!))
|
||||
(define with-dns-lookup?
|
||||
(make-ftpd-options-transformer set-ftpd-options-dns-lookup?!))
|
||||
|
||||
|
|
@ -77,10 +77,18 @@
|
|||
(loop (transformer value options)
|
||||
(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
|
||||
(really-make-session control-input-port
|
||||
control-output-port
|
||||
logfile-lock
|
||||
logged-in?
|
||||
authenticated?
|
||||
anonymous?
|
||||
|
|
@ -91,14 +99,12 @@
|
|||
reply-code
|
||||
type
|
||||
data-socket
|
||||
passive-socket
|
||||
maybe-log-port)
|
||||
passive-socket)
|
||||
session?
|
||||
(control-input-port session-control-input-port
|
||||
set-session-control-input-port!)
|
||||
(control-output-port session-control-output-port
|
||||
set-session-control-output-port!)
|
||||
(logfile-lock session-logfile-lock)
|
||||
(logged-in? session-logged-in?
|
||||
set-session-logged-in?!)
|
||||
(authenticated? session-authenticated?
|
||||
|
|
@ -112,7 +118,7 @@
|
|||
(to-be-renamed session-to-be-renamed
|
||||
set-session-to-be-renamed!)
|
||||
(replies session-replies
|
||||
set-session-replies!)
|
||||
set-session-replies!)
|
||||
(reply-code session-reply-code
|
||||
set-session-reply-code!)
|
||||
(type session-type
|
||||
|
|
@ -120,13 +126,10 @@
|
|||
(data-socket session-data-socket
|
||||
set-session-data-socket!)
|
||||
(passive-socket session-passive-socket
|
||||
set-session-passive-socket!)
|
||||
(maybe-log-port session-maybe-log-port
|
||||
set-session-maybe-log-port!))
|
||||
set-session-passive-socket!))
|
||||
|
||||
(define (make-session input-port output-port maybe-log-port)
|
||||
(define (make-session input-port output-port)
|
||||
(really-make-session input-port output-port
|
||||
(make-lock)
|
||||
#f ; logged-in?
|
||||
#f ; autenticated?
|
||||
#f ; anonymous?
|
||||
|
|
@ -138,10 +141,10 @@
|
|||
'ascii ; type
|
||||
#f ; data-socket
|
||||
#f ; passive-socket
|
||||
maybe-log-port
|
||||
))
|
||||
|
||||
(define session (make-fluid #f))
|
||||
(define server-state (make-fluid #f))
|
||||
(define options (make-fluid #f))
|
||||
|
||||
(define (make-session-selector selector)
|
||||
|
|
@ -156,8 +159,6 @@
|
|||
(make-session-selector session-control-input-port))
|
||||
(define the-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-authenticated? (make-session-selector session-authenticated?))
|
||||
|
|
@ -170,7 +171,6 @@
|
|||
(define the-session-type (make-session-selector session-type))
|
||||
(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-maybe-log-port (make-session-selector session-maybe-log-port))
|
||||
|
||||
(define set-the-session-control-input-port!
|
||||
(make-session-modifier set-session-control-input-port!))
|
||||
|
|
@ -198,8 +198,19 @@
|
|||
(make-session-modifier set-session-data-socket!))
|
||||
(define set-the-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)
|
||||
(lambda ()
|
||||
|
|
@ -211,16 +222,16 @@
|
|||
(make-ftpd-options-selector ftpd-options-anonymous-home))
|
||||
(define the-ftpd-options-banner
|
||||
(make-ftpd-options-selector ftpd-options-banner))
|
||||
(define the-ftpd-options-logfile
|
||||
(make-ftpd-options-selector ftpd-options-logfile))
|
||||
(define the-ftpd-options-log-port
|
||||
(make-ftpd-options-selector ftpd-options-log-port))
|
||||
(define the-ftpd-options-dns-lookup?
|
||||
(make-ftpd-options-selector ftpd-options-dns-lookup?))
|
||||
|
||||
;;; LOG -------------------------------------------------------
|
||||
(define (log level format-message . args)
|
||||
(syslog level
|
||||
(apply format #f (string-append "(thread ~D) " format-message)
|
||||
(thread-uid (current-thread)) args)))
|
||||
(syslog level
|
||||
(apply format #f (string-append "(thread ~D) " format-message)
|
||||
(thread-uid (current-thread)) args)))
|
||||
|
||||
(define (log-command level command-name . argument)
|
||||
(if (null? argument)
|
||||
|
|
@ -228,7 +239,7 @@
|
|||
(if (not (null? (cdr argument)))
|
||||
(log level "handling ~A command with argument ~S"
|
||||
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)))))
|
||||
|
||||
;; Extended logging like wu.ftpd:
|
||||
|
|
@ -261,53 +272,35 @@
|
|||
; 1 RFC931 Authentication
|
||||
; 13 authenticated user id (if available, '*' otherwise)
|
||||
;
|
||||
(define file-log
|
||||
(let ((maybe-dns-lookup (lambda (ip)
|
||||
(if (the-ftpd-options-dns-lookup?)
|
||||
(or (dns-lookup-ip ip)
|
||||
ip))
|
||||
ip)))
|
||||
(lambda (start-transfer-seconds info full-path direction)
|
||||
(if (the-session-maybe-log-port)
|
||||
(begin
|
||||
(obtain-lock (the-session-logfile-lock))
|
||||
(format (the-session-maybe-log-port)
|
||||
"~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
|
||||
(socket-address->string
|
||||
(socket-remote-address (the-session-data-socket)) #f)) ; remote host ip
|
||||
(file-info:size info) ; file size in bytes
|
||||
(string-map (lambda (c)
|
||||
(if (eq? c #\space) #\_ c))
|
||||
full-path) ; name of file (spaces replaced by "_")
|
||||
(case (the-session-type)
|
||||
((ascii) "a")
|
||||
((image) "b")
|
||||
(else "?")) ; transfer type
|
||||
direction ; incoming / outgoing file
|
||||
; anonymous access
|
||||
; password (no password given)
|
||||
; service name
|
||||
; authentication mode
|
||||
; authenticated user id'
|
||||
)
|
||||
(force-output (the-session-maybe-log-port))
|
||||
(release-lock (the-session-logfile-lock)))))))
|
||||
(define (file-log start-transfer-seconds info full-path direction)
|
||||
(if (the-server-state-log-port)
|
||||
(begin
|
||||
(obtain-lock (the-server-state-log-lock))
|
||||
(format (the-server-state-log-port)
|
||||
"~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%"
|
||||
(format-date "~a ~b ~d ~H:~M:~S ~Y" (date))
|
||||
(- (current-seconds) start-transfer-seconds)
|
||||
(maybe-dns-lookup
|
||||
(socket-address->string
|
||||
(socket-remote-address (the-session-data-socket)) #f))
|
||||
(file-info:size info)
|
||||
(string-map (lambda (c)
|
||||
(if (eq? c #\space) #\_ c))
|
||||
full-path)
|
||||
(case (the-session-type)
|
||||
((ascii) "a")
|
||||
((image) "b")
|
||||
(else "?"))
|
||||
direction)
|
||||
(force-output (the-server-state-log-port))
|
||||
(release-lock (the-server-state-log-lock)))))
|
||||
|
||||
(define (maybe-dns-lookup ip)
|
||||
(if (the-ftpd-options-dns-lookup?)
|
||||
(or (dns-lookup-ip ip)
|
||||
ip)
|
||||
ip))
|
||||
|
||||
(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 ------------------------------------------------
|
||||
(define (protocol-family->string protocol-family)
|
||||
(cond ((= protocol-family protocol-family/unspecified)
|
||||
|
|
@ -338,12 +331,11 @@
|
|||
#f
|
||||
(lambda ()
|
||||
(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)
|
||||
(expand-file-name (ftpd-options-anonymous-home ftpd-options)
|
||||
(cwd))
|
||||
(ftpd-options-logfile ftpd-options))
|
||||
(let ((maybe-log-port (maybe-open-logfile (ftpd-options-logfile ftpd-options))))
|
||||
(cwd)))
|
||||
(let ((the-server-state (make-server-state (ftpd-options-log-port ftpd-options))))
|
||||
(bind-listen-accept-loop
|
||||
protocol-family/internet
|
||||
(lambda (socket address)
|
||||
|
|
@ -355,10 +347,11 @@
|
|||
socket
|
||||
address
|
||||
remote-address
|
||||
maybe-log-port)))))
|
||||
the-server-state)))))
|
||||
(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
|
||||
(lambda (exit)
|
||||
(with-errno-handler*
|
||||
|
|
@ -382,7 +375,7 @@
|
|||
(handle-connection ftpd-options
|
||||
(socket:inport socket)
|
||||
(socket:outport socket)
|
||||
maybe-log-port))
|
||||
the-server-state))
|
||||
(lambda ()
|
||||
(log (syslog-level debug)
|
||||
"shutting down socket ~S"
|
||||
|
|
@ -417,7 +410,7 @@
|
|||
(handle-connection ftpd-options
|
||||
(current-input-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)
|
||||
;; 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))
|
||||
|
||||
|
||||
(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)
|
||||
"handling connection with input port ~A, output port ~A"
|
||||
input-port
|
||||
|
|
@ -447,7 +440,8 @@
|
|||
(escape 'fick-dich-ins-knie))
|
||||
(lambda ()
|
||||
(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
|
||||
(lambda ()
|
||||
(display-banner)
|
||||
|
|
@ -1305,7 +1299,7 @@
|
|||
|
||||
(define (signal-error! code message)
|
||||
(replace-reply! code message)
|
||||
(signal 'ftpd-error))
|
||||
(signal 'ftpd-error code message))
|
||||
|
||||
(define (register-reply! code . messages)
|
||||
(if (the-session-reply-code)
|
||||
|
|
|
|||
|
|
@ -203,7 +203,7 @@
|
|||
;; FTP server
|
||||
|
||||
(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
|
||||
ftpd
|
||||
ftpd-inetd))
|
||||
|
|
|
|||
Loading…
Reference in New Issue