sunet/scheme/ftpd/ftpd.scm

; RFC 959 ftp daemon

;;; This file is part of the Scheme Untergrund Networking package.

;;; Copyright (c) 1998-2002 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.

; It doesn't support the following desirable things:
;
; - Login by user
; - RESTART support
; - Banners from files on CWD
; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/


; following things should be improved:
;
; - 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.
; - default value for ftpd should be looked up as in ftp.scm

(define-record-type ftpd-options :ftpd-options
  (really-make-ftpd-options port anonymous-home banner
			    logfile 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!)
  (dns-lookup? ftpd-options-dns-lookup? set-ftpd-options-dns-lookup?!))

(define (make-default-ftpd-options)
  (really-make-ftpd-options 21
			    "~ftp"
			    (string-append "Scheme Untergrund ftp server (version "
					   sunet-version-identifier
					   ") ready.")
			    #f
			    #f))

(define (copy-ftpd-options options)
  (really-make-ftpd-options (ftpd-options-port options)
			    (ftpd-options-anonymous-home options)
			    (ftpd-options-banner options)
			    (ftpd-options-logfile options)
			    (ftpd-options-dns-lookup? options)))

(define (make-ftpd-options-transformer set-option!)
  (lambda (new-value . stuff)
    (let ((new-options (if (not (null? stuff))
			   (copy-ftpd-options (car stuff))
			   (make-default-ftpd-options))))
      (set-option! new-options new-value)
      new-options)))

(define with-port
  (make-ftpd-options-transformer set-ftpd-options-port!))
(define with-anonymous-home
  (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-dns-lookup?
  (make-ftpd-options-transformer set-ftpd-options-dns-lookup?!))

(define (make-ftpd-options . stuff)
  (let loop ((options (make-default-ftpd-options))
	     (stuff stuff))
    (if (null? stuff)
	options
	(let* ((transformer (car stuff))
	       (value (cadr stuff)))
	  (loop (transformer value options)
		(cddr stuff))))))

(define-record-type session :session
  (really-make-session control-input-port
		       control-output-port
		       logfile-lock
		       logged-in?
		       authenticated?
		       anonymous?
		       root-directory
		       current-directory
		       to-be-renamed
		       reverse-replies
		       reply-code
		       type
		       data-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?
		  set-session-authenticated?!)
  (anonymous? session-anonymous?
	      set-session-anonymous?!)
  (root-directory session-root-directory
		  set-session-root-directory!)
  (current-directory session-current-directory
		     set-session-current-directory!)
  (to-be-renamed session-to-be-renamed
		 set-session-to-be-renamed!)
  (reverse-replies session-reverse-replies
		   set-session-reverse-replies!)
  (reply-code session-reply-code
	      set-session-reply-code!)
  (type session-type
	set-session-type!)
  (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!))

(define (make-session input-port output-port maybe-log-port)
  (really-make-session input-port output-port
		       (make-lock)
		       #f		; logged-in?
		       #f		; autenticated?
		       #f		; anonymous?
		       #f		; root-directory
		       ""		; current-directory
		       #f		; to-be-renamed
		       '()		; reverse-replies
		       #f		; reply-code
		       'ascii		; type
		       #f		; data-socket
		       #f		; passive-socket
		       maybe-log-port
		       ))

(define session (make-fluid #f))
(define options (make-fluid #f))

(define (make-session-selector selector)
  (lambda ()
    (selector (fluid session))))

(define (make-session-modifier setter)
  (lambda (value)
    (setter (fluid session) value)))

(define the-session-control-input-port
  (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?))
(define the-session-anonymous? (make-session-selector session-anonymous?))
(define the-session-root-directory (make-session-selector session-root-directory))
(define the-session-current-directory (make-session-selector session-current-directory))
(define the-session-to-be-renamed (make-session-selector session-to-be-renamed))
(define the-session-reverse-replies (make-session-selector session-reverse-replies))
(define the-session-reply-code (make-session-selector session-reply-code))
(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!))
(define set-the-session-control-output-port! 
  (make-session-modifier set-session-control-output-port!))
(define set-the-session-logged-in?!
  (make-session-modifier set-session-logged-in?!))
(define set-the-session-authenticated?!
  (make-session-modifier set-session-authenticated?!))
(define set-the-session-anonymous?!
  (make-session-modifier set-session-anonymous?!))
(define set-the-session-root-directory!
  (make-session-modifier set-session-root-directory!))
(define set-the-session-current-directory!
  (make-session-modifier set-session-current-directory!))
(define set-the-session-to-be-renamed!
  (make-session-modifier set-session-to-be-renamed!))
(define set-the-session-reverse-replies!
  (make-session-modifier set-session-reverse-replies!))
(define set-the-session-reply-code!
  (make-session-modifier set-session-reply-code!))
(define set-the-session-type!
  (make-session-modifier set-session-type!))
(define set-the-session-data-socket!
  (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-ftpd-options-selector selector)
  (lambda ()
    (selector (fluid options))))

(define the-ftpd-options-port
  (make-ftpd-options-selector ftpd-options-port))
(define the-ftpd-options-anonymous-home
  (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-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)))

(define (log-command level command-name . argument)
  (if (null? argument)
      (log level "handling ~A command" command-name)
      (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?
	       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 ((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 (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)
	 "unspecified")
	((= protocol-family protocol-family/internet)
	 "internet")
	((= protocol-family protocol-family/unix)
	 "unix")
	(else "unknown")))

(define (socket->string socket)
  (format #f
	  "family: ~A, ~&local address: ~A, ~&remote address: ~A, ~&input-port ~A, ~&output-port ~A"
	  (protocol-family->string (socket:family socket))
	  (socket-address->string (socket-local-address socket))
	  (socket-address->string (socket-remote-address socket))
	  (socket:inport socket)
	  (socket:outport socket)))


;;; ftpd  -------------------------------------------------------

(define (ftpd ftpd-options)
  (display ">>>ftpd ") (write (list (ftpd-options-port ftpd-options))) (newline)
  (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"
	  (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))))
       (bind-listen-accept-loop
	protocol-family/internet
	(lambda (socket address)
	  (let ((remote-address (socket-address->string address)))
	    (set-ftp-socket-options! socket)
	    (fork-thread
	     (lambda ()
	       (handle-connection-encapsulated ftpd-options
					       socket
					       address
					       remote-address
					       maybe-log-port)))))
	(ftpd-options-port ftpd-options))))))

(define (handle-connection-encapsulated ftpd-options socket address remote-address maybe-log-port)
  (call-with-current-continuation
   (lambda (exit)
     (with-errno-handler*
      (lambda (errno packet)
	(log (syslog-level notice) 
	     "error with connection to ~A (~A)" 
	     remote-address (car packet))
	(exit 'fick-dich-ins-knie))
      (lambda ()
	(let ((socket-string (socket->string socket)))
	
	  (log (syslog-level notice)
	       "new connection to ~S"
	       remote-address)

	  (log (syslog-level debug) "socket: ~S" socket-string)
	    
	  (dynamic-wind
	   (lambda () 'fick-dich-ins-knie)
	   (lambda ()
	     (handle-connection ftpd-options
				(socket:inport socket) 
				(socket:outport socket)
				maybe-log-port))
	   (lambda ()
	     (log (syslog-level debug)
		  "shutting down socket ~S"
		  socket-string)
	     (call-with-current-continuation
	      (lambda (exit)
		(with-errno-handler*
		 (lambda (errno packet)
		   (log (syslog-level notice)
			"error shutting down socket to ~A (~A)"
			remote-address (car packet))
		   (exit 'fick-dich-ins-knie))
		 (lambda ()
		   (shutdown-socket socket shutdown/sends+receives)))))
	     (log (syslog-level notice)
		  "closing connection to ~A and finishing thread" remote-address)
	     (log (syslog-level debug)
		  "closing socket ~S" socket-string)
	     (close-socket socket)))))))))

(define (ftpd-inetd ftpd-options)
  (with-syslog-destination 
   "ftpd"
   #f
   #f
   #f
   (lambda ()
     (log (syslog-level notice)
	  "starting ftpd from inetd"
	  (expand-file-name (ftpd-options-anonymous-home ftpd-options)
			    (cwd)))
     (handle-connection ftpd-options
			(current-input-port)
			(current-output-port)
			(maybe-open-logfile (ftpd-options-logfile ftpd-options))))))

(define (set-ftp-socket-options! socket)
  ;; If the client closes the connection, we won't lose when we try to
  ;; close the socket by trying to flush the output buffer.
  ;; ... only it somehow exposes a bug in Windows Internet Explorer
  ;; so we leave it disabled.
  ;; (set-port-buffering (socket:outport socket) bufpol/none)

  (set-socket-option socket level/socket tcp/no-delay #t)

  (set-socket-option socket level/socket socket/oob-inline #t))


(define (handle-connection ftpd-options input-port output-port maybe-log-port)
  (log (syslog-level debug)
       "handling connection with input port ~A, output port ~A"
       input-port
       output-port)
  (call-with-current-continuation
   (lambda (escape)
     (with-handler
      (lambda (condition more)
	(log (syslog-level notice)
	     "hit error condition ~A (~S) -- exiting"
	     (condition-type condition)
	     (condition-stuff condition))
	(escape 'fick-dich-ins-knie))
      (lambda ()
	(let-fluids
	 session (make-session input-port output-port maybe-log-port)
	 options ftpd-options
	 (lambda ()
	   (display-banner)
	   (handle-commands))))))))

(define (display-banner)
  (log (syslog-level debug)
       "displaying banner (220)")
  (register-reply! 220
		   (the-ftpd-options-banner)))

(define-condition-type 'ftpd-quit '())
(define ftpd-quit? (condition-predicate 'ftpd-quit))

(define-condition-type 'ftpd-irregular-quit '())
(define ftpd-irregular-quit? (condition-predicate 'ftpd-irregular-quit))

(define-condition-type 'ftpd-error '())
(define ftpd-error? (condition-predicate 'ftpd-error))


(define (handle-commands)
  (log (syslog-level debug) "handling commands")
  (call-with-current-continuation
   (lambda (exit)
     (with-handler
      (lambda (condition more)
	(if (ftpd-quit? condition)
	    (begin
	      (log (syslog-level debug) "quitting (write-accept-loop)")
	      (with-handler
	       (lambda (condition ignore)
		 (more))
	       (lambda ()
		 (write-replies)
		 (exit 'fick-dich-ins-knie))))
	    (more)))
      (lambda ()
	(log (syslog-level debug)
	     "starting write-accept-loop")
	(let loop ()
	  (write-replies)
	  (accept-command)
	  (loop)))))))

(define (accept-command)
  (let* ((timeout-seconds 90)
	 (command-line (read-crlf-line-timeout (the-session-control-input-port)
					       #f
					       (* 1000 timeout-seconds);timeout
					       500)))    ; max interval
    (log (syslog-level debug) 
	 "Command line: ~A" 
	 command-line)
    (cond ((eq? command-line 'timeout)
	   (log (syslog-level notice) "hit timelimit of ~D seconds (421)"
		timeout-seconds)
	   (log (syslog-level debug)
		"so closing control connection and quitting")
	   (register-reply! 
	    421
	    (format #f "Timeout (~D seconds): closing control connection."
		    timeout-seconds)
	    (signal 'ftpd-quit)))
	   (else
	    (call-with-values
	     (lambda () (parse-command-line command-line))
	     (lambda (command arg)
	       (handle-command command arg)))))))

(define (handle-command command arg)
;  (log (syslog-level debug)
;       "handling command ~S with argument ~S"
;       command arg)
  (call-with-current-continuation
   (lambda (escape)
     (with-handler
      (lambda (condition more)
	(cond
	 ((error? condition)
	  (let ((reason (condition-stuff condition)))
	    (log (syslog-level notice)
		 "internal error occured: ~S (maybe reason: ~S) -- replying and escaping (451)"
		 condition reason)
	    (register-reply! 451
			     (format #f "Internal error: ~S" reason))
	    (escape 'fick-dich-ins-knie)))
	 ((ftpd-error? condition)
          ; debug level because nearly every unsuccessful command ends
          ; here (no args, can't change dir, etc.)
	  (log (syslog-level debug)  
	       "ftpd error occured (maybe reason: ~S)-- escaping" (condition-stuff condition))
	  (escape 'fick-dich-ins-knie))
	 (else
	  (more))))
      (lambda ()
	(with-errno-handler*
	 (lambda (errno packet)
	   (let ((unix-error (car packet)))
	     (log (syslog-level notice)
		  "unix error occured: ~S -- replying (451) and escaping"
		  unix-error)
	     (register-reply! 451
			      (format #f "Unix error: ~A." unix-error))
	     (escape 'fick-dich-ins-knie)))
	 (lambda ()
	   (dispatch-command command arg))))))))

(define (dispatch-command command arg)
;  (log (syslog-level debug)
;       "dispatching command ~S with argument ~S"
;       command arg)
  (cond
   ((assoc command *command-alist*)
    => (lambda (pair)
	 (log (syslog-level debug)
	      "command ~S was found in command-list and is executed with argument ~S"
	      (car pair) arg)
	 ((cdr pair) arg)))
   (else
    (log (syslog-level debug) "rejecting unknown command ~S (500) (argument: ~S)"
	 command arg)
    (register-reply! 500
		     (string-append
		      (format #f "Unknown command: \"~A\"" command)
		      (if (string=? "" arg)
			  "."
			  (format #f " (argument(s) \"~A\")." arg)))))))


(define (handle-user name)
  (log-command (syslog-level info) "USER" name)
  (cond
   ((the-session-logged-in?)
    (log (syslog-level info) "user ~S is already logged in (230)"
	 name)
    (register-reply! 230
		     "You are already logged in."))
   ((or (string=? "anonymous" name)
	(string=? "ftp" name))
    (handle-user-anonymous))
   (else
    (log (syslog-level info) "rejecting non-anonymous login (530)")
    (register-reply! 530
		     "Only anonymous logins allowed."))))

(define (handle-user-anonymous)
  (log (syslog-level info) "anonymous user login (230)")
  (set-the-session-logged-in?! #t)
  (set-the-session-authenticated?! #t)
  (set-the-session-anonymous?! #t)
  (set-the-session-root-directory!
   (file-name-as-directory (the-ftpd-options-anonymous-home)))
  (set-the-session-current-directory! "")
  
  (register-reply! 230 "Anonymous user logged in."))

(define (handle-pass password)
  (log-command (syslog-level info) "PASS" password)
  (cond
   ((not (the-session-logged-in?))
    (log (syslog-level info) "Rejecting password; user has not logged in yet. (530)")
    (register-reply! 530 "You have not logged in yet."))
   ((the-session-anonymous?)
    (log (syslog-level info) "Accepting password; user is logged in (200)")
    (register-reply! 200 "Thank you."))
   (else
    (log (syslog-level notice) "Reached unreachable case-branch while handling password (502)")
    (register-reply! 502 "This can't happen."))))

(define (handle-quit foo)
  (log-command (syslog-level info) "QUIT")
  (log (syslog-level debug) "quitting (221)")
  (register-reply! 221 "Goodbye!  Au revoir!  Auf Wiedersehen!")
  (signal 'ftpd-quit))

(define (handle-syst foo)
  (log-command (syslog-level info) "SYST")
  (log (syslog-level debug) "telling system type (215)")
  (register-reply! 215 "UNIX Type: L8"))

(define (handle-cwd path)
  (log-command (syslog-level info) "CWD" path)
  (ensure-authenticated-login)
  (let ((current-directory (assemble-path (the-session-current-directory)
					  path)))
    (with-errno-handler*
     (lambda (errno packet)
       (let ((error-reason (car packet)))
	 (log (syslog-level info)
	      "can't change to directory \"~A\": ~A (550)"
	      path error-reason)
	 (signal-error! 550
			(format #f "Can't change directory to \"~A\": ~A."
				path
				error-reason))))
     (lambda ()
       (with-cwd*
	(file-name-as-directory
	 (string-append (the-session-root-directory) current-directory))
	(lambda ()			; I hate gratuitous syntax
	  (log (syslog-level debug)
	       "changing current directory to \"/~A\" (250)"
	       current-directory)
	  (set-the-session-current-directory! current-directory)
	  (register-reply! 250
			   (format #f "Current directory changed to \"/~A\"."
				   current-directory))))))))

(define (handle-cdup foo)
  (log-command (syslog-level info) "CDUP")
  (handle-cwd ".."))

(define (handle-pwd foo)
  (log-command (syslog-level info) "PWD")
  (ensure-authenticated-login)
  (let ((current-directory (the-session-current-directory)))
    (log (syslog-level info) "replying \"/~A\" as current directory (257)"
	 current-directory)
    (register-reply! 257
		     (format #f "Current directory is \"/~A\"."
			     current-directory))))


(define (make-file-action-handler error-format-string action)
  (lambda (path)
    (ensure-authenticated-login)
    (if (string=? "" path)
	(begin
	  (log (syslog-level info) 
	       "finishing processing command because of missing arguments (500)")
	  (signal-error! 500 "No argument.")))
    (let ((full-path (string-append (the-session-root-directory)
				    (assemble-path (the-session-current-directory)
						   path))))
      (with-errno-handler*
       (lambda (errno packet)
	 (let ((error-reason (car packet)))
	   (log (syslog-level info)
		(string-append error-format-string " (550)") path error-reason)
	   (signal-error! 550
			  (format #f error-format-string
				  path error-reason))))
       (lambda ()
	 (action path full-path))))))

(define handle-dele
  (make-file-action-handler
   "Could not delete \"~A\": ~A."
   (lambda (path full-path)
     (log-command (syslog-level info) "DELE" path)
     (delete-file full-path)
     (log (syslog-level debug) "deleted ~S (250)" full-path)
     (log (syslog-level debug) "reporting about ~S" path)
     (register-reply! 250 (format #f "Deleted \"~A\"." path)))))

(define handle-mdtm
  (make-file-action-handler
   "Could not get info on \"~A\": ~A."
   (lambda (path full-path)
     (log-command (syslog-level info) "MDTM" path)
     (let* ((info (file-info full-path))
	    (the-date (date (file-info:mtime info) 0))
	    (formatted-date (format-date "~Y~m~d~H~M~S" the-date)))
       (log (syslog-level debug) "reporting modification time of ~S: ~A (213)"
	    full-path
	    formatted-date)
       (register-reply! 213
			formatted-date)))))

(define handle-mkd
  (make-file-action-handler
   "Could not make directory \"~A\": ~A."
   (lambda (path full-path)
     (log-command (syslog-level info) "MKD" path)
     (create-directory full-path #o755)
     (log (syslog-level debug) "created directory ~S (257)" full-path)
     (log (syslog-level debug) "reporting about ~S" path)
     (register-reply! 257
		      (format #f "Created directory \"~A\"." path)))))

(define handle-rmd
  (make-file-action-handler
   "Could not remove directory \"~A\": ~A."
   (lambda (path full-path)
     (log-command (syslog-level info) "RMD" path)
     (delete-directory full-path)
     (log (syslog-level debug) "deleted directory ~S (250)" full-path)
     (log (syslog-level debug) "reporting about ~S" path)
     (register-reply! 250
		      (format #f "Deleted directory \"~A\"." path)))))


(define handle-rnfr
  (make-file-action-handler
   "Could not get info on file \"~A\": ~A."
   (lambda (path full-path)
     (log-command (syslog-level info) "RNFR" path)
     (file-info full-path)
     (log (syslog-level debug) 
	  "RNFR-command accepted, waiting for RNTO-command (350)")
     (register-reply! 350 "RNFR accepted.  Gimme a RNTO next.")
     (set-the-session-to-be-renamed! full-path))))

(define (handle-rnto path)
  (log-command (syslog-level info) "RNTO" path)
  (ensure-authenticated-login)
  (if (not (the-session-to-be-renamed))
      (begin
	(log (syslog-level info) 
	     "RNTO-command rejected: need RNFR-command before (503)")
	(signal-error! 503 "Need RNFR before RNTO.")))
  (if (string=? "" path)
      (begin
	(log (syslog-level info)
	     "No argument -- still waiting for (correct) RNTO-command (500)")
	(signal-error! 500 "No argument.")))
  (let ((full-path (string-append (the-session-root-directory)
				  (assemble-path (the-session-current-directory)
						 path))))

    (if (file-exists? full-path)
	(begin
	  (log (syslog-level info) "rename of ~S failed (already exists) (550)"
	       full-path)
	  (log (syslog-level debug) "reporting about ~S" 
	       path)
	  (signal-error!
	   550
	   (format #f "Rename failed---\"~A\" already exists or is protected."
		   path))))

    (with-errno-handler*
     (lambda (errno packet)
       (log (syslog-level info)
	    "failed to rename ~A (550)" path)
       (signal-error! 550
		      (format #f "Could not rename: ~A." path)))
     (lambda ()
       (let ((old-name (the-session-to-be-renamed)))
	 (rename-file old-name full-path)
	 (log (syslog-level debug)
	      "~S renamed to ~S - no more waiting for RNTO-command (250)"
	      old-name full-path)
	 (register-reply! 250 "File renamed.")
	 (set-the-session-to-be-renamed! #f))))))
  
(define handle-size
  (make-file-action-handler
   "Could not get info on file \"~A\": ~A."
   (lambda (path full-path)
     (log-command (syslog-level info) "SIZE" path)
     (let ((info (file-info full-path)))
       (if (not (eq? 'regular (file-info:type info)))
	   (begin
	     (log (syslog-level info)
		  "rejecting SIZE-command as ~S is not a regular file (550)"
		  full-path)
	     (log (syslog-level debug) "reporting about ~S" path)
	     (signal-error! 550
			    (format #f "\"~A\" is not a regular file."
				    path))))
       (let ((file-size (file-info:size info)))
	 (log (syslog-level debug)
	      "reporting ~D as size of ~S (213)"
	      file-size full-path)
	 (register-reply! 213 (number->string file-size)))))))


(define (handle-type arg)
  (log-command (syslog-level info) "TYPE" arg)
  (cond
   ((string-ci=? "A" arg)
    (log (syslog-level debug) "changed type to ascii (200)")
    (set-the-session-type! 'ascii))
   ((string-ci=? "I" arg)
    (log (syslog-level debug) "changed type to image (8-bit binary) (200)")
    (set-the-session-type! 'image))
   ((string-ci=? "L8" arg)
    (log (syslog-level debug) "changed type to image (8-bit binary) (200)")
    (set-the-session-type! 'image))
   (else
    (log (syslog-level info)
	 "rejecting TYPE-command: unknown type (504)")
    (signal-error! 504
		   (format #f "Unknown TYPE: ~S." arg))))

  (log (syslog-level debug) "reporting new type (see above)")
  (register-reply! 200
		   (format #f "TYPE is now ~A."
			   (case (the-session-type)
			     ((ascii) "ASCII")
			     ((image) "8-bit binary")
			     (else "somethin' weird, man")))))

(define (handle-mode arg)
  (log-command (syslog-level info) "MODE" arg)
  (cond
   ((string=? "" arg)
    (log (syslog-level info) "rejecting MODE-command: no arguments (500)")
    (register-reply! 500
		     "No arguments.  Not to worry---I'd ignore them anyway."))
   ((string-ci=? "S" arg)
    (log (syslog-level info) 
	 "stream mode is (still) used for file-transfer (200)")
    (register-reply! 200 "Using stream mode to transfer files."))
   (else
    (log (syslog-level info) "mode ~S is not supported (504)" arg)
    (register-reply! 504 (format #f "Mode \"~A\" is not supported."
				 arg)))))

(define (handle-stru arg)
  (log-command (syslog-level info) "STRU" arg)
  (cond
   ((string=? "" arg)
    (log (syslog-level info) "rejecting STRU-command: no arguments (500)")
    (register-reply! 500
		     "No arguments.  Not to worry---I'd ignore them anyway."))
   ((string-ci=? "F" arg)
    (log (syslog-level debug) "(still) using file structure to transfer files (200)")
    (register-reply! 200 "Using file structure to transfer files."))
   (else
    (log (syslog-level info) "file structure ~S is not supported (504)" arg)
    (register-reply! 504
		     (format #f "File structure \"~A\" is not supported."
			     arg)))))

(define (handle-noop arg)
  (log-command (syslog-level info) "NOOP")
  (log (syslog-level debug) "successfully done nothing (200)")
  (register-reply! 200 "Done nothing, but successfully."))

(define *port-arg-regexp*
  (make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))

(define (parse-port-arg string)
  (log (syslog-level debug) "parsing port-string ~S" string)
  (cond
   ((regexp-exec *port-arg-regexp* string)
    => (lambda (match)
	 (let ((components
		(map (lambda (match-index)
		       (string->number
			(match:substring match match-index)))
		     '(1 2 3 4 5 6))))
	   (if (any (lambda (component)
		      (> component 255))
		    components)
	       (begin
		 (log (syslog-level debug)
		      "rejecting PORT-command because of invalid arguments (port-component > 255) (501)")
		 (signal-error! 501
				"Invalid arguments to PORT.")))
	   (apply
	    (lambda (a1 a2 a3 a4 p1 p2)
	      (let ((address (+ (arithmetic-shift a1 24)
				(arithmetic-shift a2 16)
				(arithmetic-shift a3 8)
				a4))
		    (port (+ (arithmetic-shift p1 8) p2)))
		(log (syslog-level debug)
		     "port-parse result: address ~D, port ~D (from compononets: address: ~A, ~A, ~A, ~A, port: ~A, ~A)"
		     address port
		     a1 a2 a3 a4 p1 p2)
		 (values address port)))
	    components))))
   (else
    (log (syslog-level debug) "reporting syntax error in argument (500)")
    (signal-error! 500
		   "Syntax error in argument to PORT."))))


(define (handle-port stuff)
  (log-command (syslog-level info) "PORT" stuff)
  (ensure-authenticated-login)
  (maybe-close-data-connection)
  (call-with-values
   (lambda () (parse-port-arg stuff))
   (lambda (address port)
     (let ((socket (create-socket protocol-family/internet
				  socket-type/stream)))
       (log (syslog-level debug)
	    "created new socket (internet, stream, reusing address)")
       (set-socket-option socket level/socket socket/reuse-address #t)

       (connect-socket socket
		       (internet-address->socket-address
			address port))
       
       (set-the-session-data-socket! socket)

       (let ((formatted-internet-host-address 
	      (format-internet-host-address address)))
	 (log (syslog-level debug)
	      "connected to ~A, port ~A (200)" 
	      formatted-internet-host-address port)

	 (register-reply! 200
			  (format #f "Connected to ~A, port ~A."
				  formatted-internet-host-address 
				  port)))))))


(define (handle-pasv stuff)
  (log-command (syslog-level info) "PASV")
  (ensure-authenticated-login)
  (maybe-close-data-connection)
  (let ((socket (create-socket protocol-family/internet
			       socket-type/stream)))
    
    (set-socket-option socket level/socket socket/reuse-address #t)

    (bind-socket socket
		 (internet-address->socket-address (this-host-address)
						   0))
    (listen-socket socket 1)

    (let ((address (socket-local-address socket)))

      (call-with-values
       (lambda () (socket-address->internet-address address))
       (lambda (host-address port)

	 (set-the-session-passive-socket! socket)


	 (let ((formatted-this-host-address 
		(format-internet-host-address (this-host-address) ","))
	       (formatted-port (format-port port)))
	   (log (syslog-level debug) "accepting passive mode (on ~A,~A) (227)"
		formatted-this-host-address formatted-port)
	   (register-reply! 227
			    (format #f "Passive mode OK (~A,~A)"
				    formatted-this-host-address
				    formatted-port))))))))

(define (this-host-address)
  (let ((socket (port->socket (the-session-control-input-port)
			      protocol-family/internet)))
    (call-with-values
     (lambda () 
       (socket-address->internet-address 
	(socket-local-address socket)))
     (lambda (host-address control-port)
       (log (syslog-level debug) "Closing ~A ~A"
	    (socket:inport socket) (socket:outport socket))
       (close-socket socket)
       host-address))))

(define (handle-nlst arg)
  (log-command (syslog-level info) "NLST" arg)
  (handle-listing arg '()))

(define (handle-list arg)
  (log-command (syslog-level info) "LIST" arg)
  (handle-listing arg '(long)))
  
(define (handle-listing arg preset-flags)
  (ensure-authenticated-login)
  (with-data-connection
   (lambda ()
     (let ((args (split-arguments arg)))
       (call-with-values
	(lambda ()
	  (partition
	   (lambda (arg)
	     (and (not (string=? "" arg))
		  (char=? #\- (string-ref arg 0))))
	   args))
	(lambda (flag-args rest-args)

	  (if (and (not (null? rest-args))
		   (not (null? (cdr rest-args))))
	      (begin
		(log (syslog-level info) "got more than one path argument - rejection (501)")
		(signal-error! 501 "More than one path argument.")))

	  (let ((path (if (null? rest-args)
			  ""
			  (car rest-args)))
		(flags (arguments->ls-flags flag-args)))

	    (if (not flags)
		(begin
		  (log (syslog-level info) "got invalid flags (501)")
		  (signal-error! 501 "Invalid flag(s).")))
	    (let ((all-flags (append preset-flags flags)))
	      (log (syslog-level debug)
		   "sending file-listing for path ~S with flags ~A"
		   path all-flags)

	      (generate-listing path all-flags)))))))))

; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
; ENSURE-DATA-CONNECTION.

(define (generate-listing path flags)
  (let ((full-path (string-append (the-session-root-directory)
				  (assemble-path (the-session-current-directory)
						 path))))
    (with-errno-handler*
     (lambda (errno packet)
       (let ((error-reason (car packet)))
	 (log (syslog-level info) 
	      "can't access directory at ~A: ~A (451)"
	      path error-reason)
	 (signal-error! 451
			(format #f "Can't access directory at ~A: ~A."
				path
				error-reason))))
     (lambda ()
       (with-cwd*
	(file-name-directory full-path)
	(lambda ()
	  (let ((nondir (file-name-nondirectory full-path)))
	    (let-fluid
	     ls-crlf? #t
	     (lambda ()
	       (ls flags
		   (list
		    ;; work around OLIN BUG
		    (if (string=? nondir "")
			"."
			nondir))
		   (socket:outport (the-session-data-socket))))))))))))

(define (handle-abor foo)
  (log-command (syslog-level info) "ABOR")
  (maybe-close-data-connection)
  (log (syslog-level debug) "closing data connection (226)")
  (register-reply! 226 "Closing data connection."))

(define (handle-retr path)
  (log-command (syslog-level info) "RETR" path)
  (ensure-authenticated-login)
  (let ((full-path (string-append (the-session-root-directory)
				  (assemble-path (the-session-current-directory)
						 path))))
    (with-fatal-error-handler*		; CALL-WITH-INPUT-FILE doesn't go through ERRNO
     (lambda (condition more)
       (let ((reason (condition-stuff condition)))
	 (log (syslog-level info) "failed to open ~S for reading (maybe reason: ~S) (550)" full-path reason)
	 (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason)
	 (signal-error! 550
			(format #f "Can't open \"~A\" for reading."
				path))))
     (lambda ()
       (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)" 
		    full-path)
	       (log (syslog-level debug) "reporting about ~S" path)
	       (signal-error! 450
			      (format #f "\"~A\" is not a regular file."
				      path))))
	 (call-with-input-file full-path
	   (lambda (file-port)
	     (with-data-connection
	      (lambda ()
		(case (the-session-type)
		  ((image)
		   (log (syslog-level debug) 
			"sending file ~S (binary mode)"
			full-path)
		   (log (syslog-level debug) "sending is from port ~S" file-port)
		   (copy-port->port-binary
		    file-port
		    (socket:outport (the-session-data-socket))))
		  ((ascii)
		   (log (syslog-level debug) "sending file ~S (ascii mode)" 
			full-path)
		   (log (syslog-level debug) "sending is from port ~S" file-port)
		   (copy-port->port-ascii
		    file-port
		    (socket:outport (the-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)
  (ensure-authenticated-login)
  (let ((full-path (string-append (the-session-root-directory)
				  (assemble-path (the-session-current-directory)
						 path))))
    (with-fatal-error-handler*
     (lambda (condition more)
       (let ((reason (condition-stuff condition)))
	 (log (syslog-level info) "can't open ~S for writing (maybe reason: ~S) (550)" full-path reason)
	 (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 ()
       (let ((start-transfer-seconds (current-seconds)))
	 (call-with-output-file full-path
	   (lambda (file-port)
	     (with-data-connection
	      (lambda ()
		(let ((inport (socket:inport (the-session-data-socket))))
		  (case (the-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 (the-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 (the-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"
       path)
  (let* ((interim-path
	  (if (not (file-name-rooted? path))
	      (string-append (file-name-as-directory current-directory)
			     path)
	      path))
	 (complete-path (if (file-name-rooted? interim-path)
			    (file-name-sans-rooted interim-path)
			    interim-path)))
    (log (syslog-level debug) "name ~S assembled to ~S"
	 path complete-path)
    (cond
     ((normalize-path complete-path)
      => (lambda (assembled-path) assembled-path))
     (else
      (log (syslog-level debug) 
	   "invalid pathname -- tried to pass root directory (501)")
      (signal-error! 501 "Invalid pathname")))))

(define (ensure-authenticated-login)
  (if (or (not (the-session-logged-in?))
	  (not (the-session-authenticated?))) 
      (begin
	(log (syslog-level debug) 
	     "login authentication failed - user is not logged in (530)")
	(signal-error! 530 "You're not logged in yet."))
      (log (syslog-level debug) "authenticated login ensured")))

(define (with-data-connection thunk)
  (dynamic-wind ensure-data-connection
		thunk
		maybe-close-data-connection))
  
(define *window-size* 51200)

(define (ensure-data-connection)
  (if (and (not (the-session-data-socket)) 
	   (not (the-session-passive-socket)))
      (begin 
	(log (syslog-level debug) "no data connection (425)")
	(signal-error! 425 "No data connection.")))

  (if (the-session-passive-socket)
      (call-with-values
       (lambda () (accept-connection (the-session-passive-socket)))
       (lambda (socket socket-address)
	 (set-the-session-data-socket! socket))))

  (log (syslog-level debug) "opening data connection (150)")
  (register-reply! 150 "Opening data connection.")
  (write-replies)

  (set-socket-option (the-session-data-socket) level/socket
		     socket/send-buffer *window-size*)
  (set-socket-option (the-session-data-socket) level/socket
		     socket/receive-buffer *window-size*))

(define (maybe-close-data-connection)
  (if (or (the-session-data-socket) (the-session-passive-socket))
      (close-data-connection)))

(define (close-data-connection)
  (if (the-session-data-socket)
      (close-socket (the-session-data-socket)))
  (if (the-session-passive-socket)
      (close-socket (the-session-passive-socket)))
  (log (syslog-level debug) "closing data connection (226)")
  (register-reply! 226 "Closing data connection.")
  (set-the-session-data-socket! #f)
  (set-the-session-passive-socket! #f))

(define *command-alist*
  (list
   (cons "NOOP" handle-noop)
   (cons "USER" handle-user)
   (cons "PASS" handle-pass)
   (cons "QUIT" handle-quit)
   (cons "SYST" handle-syst)
   (cons "CWD" handle-cwd)
   (cons "PWD" handle-pwd)
   (cons "CDUP" handle-cdup)
   (cons "DELE" handle-dele)
   (cons "MDTM" handle-mdtm)
   (cons "MKD" handle-mkd)
   (cons "RMD" handle-rmd)
   (cons "RNFR" handle-rnfr)
   (cons "RNTO" handle-rnto)
   (cons "SIZE" handle-size)
   (cons "TYPE" handle-type)
   (cons "MODE" handle-mode)
   (cons "STRU" handle-stru)
   (cons "PORT" handle-port)
   (cons "PASV" handle-pasv)
   (cons "NLST" handle-nlst)
   (cons "LIST" handle-list)
   (cons "RETR" handle-retr)
   (cons "STOR" handle-stor)
   (cons "ABOR" handle-abor)))

(define (parse-command-line line)
  (if (eof-object? line) ; Netscape does this
      (signal 'ftpd-irregular-quit)
      (let* ((line (string-trim-both line char-set:whitespace))
	     (split-position (string-index line #\space)))
	(if split-position
	    (values (string-map char-upcase (substring line 0 split-position))
		    (string-trim-both (substring line
						 (+ 1 split-position)
						 (string-length line))
				      char-set:whitespace))
	    (values (string-map char-upcase line) "")))))

; Path names

; This removes all internal ..'s from a path.
; NORMALIZE-PATH returns #f if PATH points to a parent directory.

(define (normalize-path path)
  (let loop ((components (split-file-name (simplify-file-name path)))
	     (reverse-result '()))
    (cond
     ((null? components)
      (path-list->file-name (reverse reverse-result)))
     ((string=? ".." (car components))
      (if (null? reverse-result)
	  #f
	  (loop (cdr components) (cdr reverse-result))))
     (else
      (loop (cdr components) (cons (car components) reverse-result))))))

(define (file-name-rooted? file-name)
  (and (not (string=? "" file-name))
       (char=? #\/ (string-ref file-name 0))))

(define (file-name-sans-rooted file-name)
  (substring file-name 1 (string-length file-name)))

(define split-arguments
  (infix-splitter (make-regexp " +")))

; Reply handling

; Replies must be synchronous with requests and actions.  Therefore,
; they are queued on generation via REGISTER-REPLY!.  The messages are
; printed via WRITE-REPLIES.  For the nature of the replies, see RFC
; 959.


(define (write-replies)
  (if (not (null? (the-session-reverse-replies)))
      (let loop ((messages (reverse (the-session-reverse-replies))))
	(if (null? (cdr messages))
	    (write-final-reply (car messages))
	    (begin
	      (write-nonfinal-reply (car messages))
	      (loop (cdr messages))))))
  (set-the-session-reverse-replies! '()))

(define (write-final-reply line)
  (format (the-session-control-output-port) "~D ~A" (the-session-reply-code) line)
  (log (syslog-level debug) "Reply: ~D ~A~%" (the-session-reply-code) line)
  (write-crlf (the-session-control-output-port))
  (force-output (the-session-control-output-port)))

(define (write-nonfinal-reply line)
  (format (the-session-control-output-port) "~D-~A" (the-session-reply-code) line)
  (log (syslog-level debug) "Reply: ~D-~A~%" (the-session-reply-code) line)
  (write-crlf (the-session-control-output-port)))

(define (signal-error! code message)
  (register-reply! code message)
  (signal 'ftpd-error))

(define (register-reply! code message)
  (set-the-session-reverse-replies!
	(cons message (the-session-reverse-replies)))
  (set-the-session-reply-code! code))

(define (copy-port->port-binary input-port output-port)
  (let ((buffer (make-string *window-size*)))
    (let loop ()
      (cond
       ((read-string! buffer input-port)
	=> (lambda (length)
	     (write-string buffer output-port 0 length)
	     (loop))))))
  (force-output output-port))

(define (copy-port->port-ascii input-port output-port)
  (let loop ()
    (let ((line (read-line input-port 'concat)))
      (if (not (eof-object? line))
	  (let ((length (string-length line)))
	    (cond
	     ((zero? length)
	      'fick-dich-ins-knie)
	     ((char=? #\newline (string-ref line (- length 1)))
	      (write-string line output-port 0 (- length 1))
	      (write-crlf output-port))
	     (else
	      (write-string line output-port)))
	    (loop)))))
  (force-output output-port))

(define (copy-ascii-port->port input-port output-port)
  (let loop ()
    (let* ((line (read-crlf-line input-port
				 #f))
	   (length (string-length line)))
      (if (not (eof-object? line))
	  (begin
	    (write-string line output-port 0 length)
	    (newline output-port)
	    (loop)))))
  (force-output output-port))