From eb20aec688824c7030e43da70776fab7b4bb19c8 Mon Sep 17 00:00:00 2001 From: sperber Date: Tue, 28 Jan 2003 10:49:45 +0000 Subject: [PATCH] Clean up logging in ftpd: - hold relevant data in new SERVER-STATE fluid - specify log destination as a port, not a file --- doc/latex/ftpd.tex | 8 +-- scheme/ftpd/ftpd.scm | 162 +++++++++++++++++++++---------------------- scheme/packages.scm | 2 +- 3 files changed, 83 insertions(+), 89 deletions(-) diff --git a/doc/latex/ftpd.tex b/doc/latex/ftpd.tex index a2c2af3..c9864d8 100644 --- a/doc/latex/ftpd.tex +++ b/doc/latex/ftpd.tex @@ -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} diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm index df16a27..6c01a00 100644 --- a/scheme/ftpd/ftpd.scm +++ b/scheme/ftpd/ftpd.scm @@ -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) diff --git a/scheme/packages.scm b/scheme/packages.scm index 8e6fc1b..d2382d8 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -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))