diff --git a/doc/latex/ftpd.tex b/doc/latex/ftpd.tex index ac1b66b..f624237 100644 --- a/doc/latex/ftpd.tex +++ b/doc/latex/ftpd.tex @@ -9,19 +9,44 @@ \subsubsection*{Entry points} -\defun {ftpd} {anonymous-home \ovar{port}} {\noreturn} +\defun {ftpd} {anonymous-home \ovar{port \ovar{logfile}}} {\noreturn} \begin{defundescx}{ftp-inetd} {anonymous-home} {\noreturn} \ex{ftpd} starts the server, using \semvar{anonymous-home} as the root directory of the server. Usage of relative paths is not encouraged. \semvar{port} specifies the port the server is - listening for connections. It defaults to 21. - + listening for connections. It defaults to 21. \ex{ftpd} makes a log + entry for each file sent or retrieved. These logs are written to + \semvar{logfile}, if given. + + The log format of \ex{ftpd} is the same as the one of + \ex{wuftpd}. The fields are seperated by spaces and contain + following informations: +\codex{Fri Apr 19 17:08:14 2002 4 134.2.2.171 56881 /files.lst b \_ i a nop@ssword ftp 0 *} + \begin{enumerate} +\item Current date and time. This field contains + spaces and is 24 characters long. +\item Transfer time in seconds. +\item Remote host IP (wuftpd puts the name here). +\item File size in bytes +\item Name of file +\item Transfer type: \underline{a}scii or \underline{b}inary (image type). +\item Special action flags. As \ex{ftpd} does not support any special +action, we are always `\ex{\_}' here. +\item File was sent to user (\underline{o}utgoing) or received from user +(\underline{i}ncoming) +\item \underline{A}nonymous access +\item Anonymous ftp password. We do not use anyone. +\item Service name - always \ex{ftp}. +\item Authentication mode (always none = `\ex{0}'). +\item Authenticated user ID (always not available = `\ex{*}') +\end{enumerate} + As the procedure does not return, you have to do a \ex{fork} in - order to have a ``real'' daemon: - \codex{(fork (lambda () (ftpd "/data/ftp" 8080)))} - \ex{ftpd-inetd} is the version to be used with a daemon like - \ex{inetd}. If the server is started this way, it handles the - connection through the current standard output and input ports. + order to have a ``real'' daemon: \codex{(fork (lambda () (ftpd + "/data/ftp" 8080)))} \ex{ftpd-inetd} is the version to be used with + a daemon like \ex{inetd}. If the server is started this way, it + handles the connection through the current standard output and input + ports. \end{defundescx} \subsubsection*{Examples} diff --git a/ftpd.scm b/ftpd.scm index fb8b342..b8747df 100644 --- a/ftpd.scm +++ b/ftpd.scm @@ -13,11 +13,12 @@ ; following things should be improved: ; -; - GET-command: ftpd reports "Can't open FILENAME for reading" if +; - GET/RETR-command: ftpd reports "Can't open FILENAME for reading" if ; file actually doesn't exist. This is confusing. Reporting ; "FILENAME does not exist" is much better. +(define *logfile* #f) ; file-port to log to like wu-ftpd (analyzable with webalizer) (define-record session control-input-port @@ -93,7 +94,62 @@ (log level "handling ~A-command with argument ~S" ; does this ever happen? command-name (car argument))))) +;; Extended logging like wu.ftpd: +;; Each file up/download is protocolled +; Mon Dec 3 18:52:41 1990 1 wuarchive.wustl.edu 568881 /files.lst.Z a _ o a chris@wugate.wustl.edu ftp 0 * +; +; %.24s %d %s %d %s %c %s %c %c %s %s %d %s +; 1 2 3 4 5 6 7 8 9 10 11 12 13 +; +; 1 current time in the form DDD MMM dd hh:mm:ss YYYY +; 2 transfer time in seconds +; 3 remote host name +; 4 file size in bytes +; 5 name of file +; 6 transfer type (a>scii, b>inary) +; 7 special action flags (concatenated as needed): +; C file was compressed +; U file was uncompressed +; T file was tar'ed +; _ no action taken +; 8 file was sent to user (o>utgoing) or received from +; user (i>ncoming) +; 9 accessed anonymously (r>eal, a>nonymous, g>uest) -- mostly for FTP +; 10 local username or, if guest, ID string given +; (anonymous FTP password) +; 11 service name ('ftp', other) +; 12 authentication method (bitmask) +; 0 none +; 1 RFC931 Authentication +; 13 authenticated user id (if available, '*' otherwise) +; +(define file-log + (let ((file-log-lock (make-lock))) + (lambda (start-transfer-seconds info full-path direction) + (if *logfile* + (begin + (obtain-lock file-log-lock) + (format *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 + (socket-address->string (socket-remote-address (session-data-socket)) #f) ; remote host name + (file-info:size info) ; file size in bytes + full-path ; name of file + (case (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 *logfile*) + (release-lock file-log-lock)))))) + ;;; CONVERTERS ------------------------------------------------ (define (protocol-family->string protocol-family) (cond ((= protocol-family protocol-family/unspecified) @@ -113,40 +169,49 @@ (socket:outport socket))) -(define (socket-address->string socket-address) - (call-with-values - (lambda () (socket-address->internet-address socket-address)) - (lambda (host-address service-port) - (format #f "~A:~A" - (format-internet-host-address host-address) - (format-port service-port))))) +(define (socket-address->string socket-address . with-port?) + (let ((with-port? (optional with-port? #t))) + (receive (host-address service-port) + (socket-address->internet-address socket-address) + (if with-port? + (format #f "~A:~A" + (format-internet-host-address host-address) + (format-port service-port)) + (format #f "~A" + (format-internet-host-address host-address)))))) ;;; ftpd ------------------------------------------------------- -(define (ftpd anonymous-home . maybe-port) - (let ((port (optional maybe-port 21))) - (with-syslog-destination - "ftpd" - #f - #f - #f - (lambda () - (log (syslog-level notice) - "starting daemon on port ~D with ~S as anonymous home" - port (expand-file-name anonymous-home (cwd))) +(define (ftpd anonymous-home . maybe-args) + (let-optionals + maybe-args + ((port 21) + (logfile #f)) + (display "ping!\n") + (if logfile + (set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append)))) + (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 () @@ -193,7 +258,16 @@ "closing socket ~S" socket-string) (close-socket socket)))))))))) -(define (ftpd-inetd anonymous-home) +(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)))))) + (with-syslog-destination "ftpd" #f @@ -883,7 +957,8 @@ (format #f "Can't open \"~A\" for reading." path)))) (lambda () - (let ((info (file-info full-path))) + (let ((info (file-info full-path)) + (start-transfer-seconds (current-seconds))) (if (not (eq? 'regular (file-info:type info))) (begin (log (syslog-level info) "rejecting RETR-command as ~S is not a regular file (450)" @@ -911,7 +986,11 @@ (log (syslog-level debug) "sending is from port ~S" file-port) (copy-port->port-ascii file-port - (socket:outport (session-data-socket)))))))))))))) + (socket:outport (session-data-socket))))) + (file-log start-transfer-seconds info full-path "o")))))))))) + +(define (current-seconds) + (receive (time ticks) (time+ticks) time)) (define (handle-stor path) (log-command (syslog-level info) "STOR" path) @@ -926,32 +1005,35 @@ (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason) (signal-error! 550 (format #f "Can't open \"~A\" for writing." path)))) (lambda () - (call-with-output-file full-path - (lambda (file-port) - (with-data-connection - (lambda () - (let ((inport (socket:inport (session-data-socket)))) - (case (session-type) - ((image) - (log (syslog-level notice) - "storing data to ~S (binary mode)" - full-path) - (log (syslog-level debug) - "storing comes from socket-inport ~S (binary-mode)" - inport) - (copy-port->port-binary - (socket:inport (session-data-socket)) - file-port)) - ((ascii) - (log (syslog-level notice) - "storing data to ~S (ascii-mode)" - full-path) - (log (syslog-level debug) - "storing comes from socket-inport ~S (ascii-mode)" - inport) - (copy-ascii-port->port - (socket:inport (session-data-socket)) - file-port)))))))))))) + (let ((start-transfer-seconds (current-seconds))) + (call-with-output-file full-path + (lambda (file-port) + (with-data-connection + (lambda () + (let ((inport (socket:inport (session-data-socket)))) + (case (session-type) + ((image) + (log (syslog-level notice) + "storing data to ~S (binary mode)" + full-path) + (log (syslog-level debug) + "storing comes from socket-inport ~S (binary-mode)" + inport) + (copy-port->port-binary + (socket:inport (session-data-socket)) + file-port)) + ((ascii) + (log (syslog-level notice) + "storing data to ~S (ascii-mode)" + full-path) + (log (syslog-level debug) + "storing comes from socket-inport ~S (ascii-mode)" + inport) + (copy-ascii-port->port + (socket:inport (session-data-socket)) + file-port))) + (file-log start-transfer-seconds (file-info full-path) full-path "i") + )))))))))) (define (assemble-path current-directory path) (log (syslog-level debug) "assembling path ~S" @@ -1133,7 +1215,7 @@ ; Version -(define *ftpd-version* "$Revision: 1.32 $") +(define *ftpd-version* "$Revision: 1.33 $") (define (copy-port->port-binary input-port output-port) (let ((buffer (make-string *window-size*))) diff --git a/modules.scm b/modules.scm index 890a577..224559a 100644 --- a/modules.scm +++ b/modules.scm @@ -537,18 +537,21 @@ ftpd-inetd)) (define-structure ftpd ftpd-interface - (open scheme + (open scsh conditions handle signals structure-refs handle-fatal-error - scsh + scheme threads threads-internal ; last one to get CURRENT-THREAD + locks thread-fluids ; fork-thread fluids string-lib big-util defrec-package crlf-io strings ls + let-opt + receiving ; RECEIVE format-net) ; pretty print of internet-addresses (access big-scheme) (files ftpd))