* added file logging like wu-ftpd does
This commit is contained in:
interp
parent
48a0a95a4a
commit
fb0833078b
|
|
@ -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}
|
||||
|
|
|
|||
204
ftpd.scm
204
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*)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue