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

@@ -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
+  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}
 
 \defun{with-dns-lookup?}{boolean [options]}{options}

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
+(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?
   (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
+		       passive-socket)
-		       maybe-log-port)
   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?
@@ -120,13 +126,10 @@
   (data-socket session-data-socket
 	       set-session-data-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
-		       (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,8 +222,8 @@
   (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
+(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?
   (make-ftpd-options-selector ftpd-options-dns-lookup?))
 
@@ -261,52 +272,34 @@
 ;               1   RFC931 Authentication
 ;        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?)
-				(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))
+	(obtain-lock (the-server-state-log-lock))
-	    (format (the-session-maybe-log-port)
+	(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 date and time
+		(format-date "~a ~b ~d ~H:~M:~S ~Y" (date))
-		    (- (current-seconds) start-transfer-seconds) ; transfer time in secs
+		(- (current-seconds) start-transfer-seconds)
 		(maybe-dns-lookup
 		 (socket-address->string 
-		      (socket-remote-address (the-session-data-socket)) #f)) ; remote host ip
+		  (socket-remote-address (the-session-data-socket)) #f))
-		    (file-info:size info) ; file size in bytes
+		(file-info:size info)
 		(string-map (lambda (c) 
 			      (if (eq? c #\space) #\_ c)) 
-				full-path) ; name of file (spaces replaced by "_")
+			    full-path)
 		(case (the-session-type)
 		  ((ascii) "a")
 		  ((image) "b")
-		      (else "?"))	; transfer type
+		  (else "?"))
-		    direction		; incoming / outgoing file
+		direction)
-					; anonymous access
+	(force-output (the-server-state-log-port))
-					; password (no password given)
+	(release-lock (the-server-state-log-lock)))))
-					; 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)
+(define (maybe-dns-lookup ip)
-  (with-errno-handler
+  (if (the-ftpd-options-dns-lookup?)
-   ((errno packet)
+      (or (dns-lookup-ip ip)
-    (else
+	  ip)
-     (format (current-error-port) 
+      ip))
-	     "[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)
@@ -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))
+			    (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
 	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)

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))