; 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; this requires crypt which scsh doesn't have
; - 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 options
logfile
logfile-lock
dns-lookup?)
(define-record session
control-input-port
control-output-port
anonymous-home
(logged-in? #f)
(authenticated? #f)
(anonymous? #f)
(root-directory #f)
(current-directory "")
(to-be-renamed #f)
(reverse-replies '())
(reply-code #f) ; the last one wins
(type 'ascii) ; PLEASE set this to bin
(data-socket #f)
(passive-socket #f))
(define session (make-fluid #f))
(define options (make-preserved-thread-fluid
(make-options #f #f #f)))
(define (make-fluid-selector selector)
(lambda () (selector (fluid session))))
(define (make-fluid-setter setter)
(lambda (value)
(setter (fluid session) value)))
(define session-control-input-port (make-fluid-selector session:control-input-port))
(define session-control-output-port (make-fluid-selector session:control-output-port))
(define session-anonymous-home (make-fluid-selector session:anonymous-home))
(define session-logged-in? (make-fluid-selector session:logged-in?))
(define session-authenticated? (make-fluid-selector session:authenticated?))
(define session-anonymous? (make-fluid-selector session:anonymous?))
(define session-root-directory (make-fluid-selector session:root-directory))
(define session-current-directory (make-fluid-selector session:current-directory))
(define session-to-be-renamed (make-fluid-selector session:to-be-renamed))
(define session-reverse-replies (make-fluid-selector session:reverse-replies))
(define session-reply-code (make-fluid-selector session:reply-code))
(define session-type (make-fluid-selector session:type))
(define session-data-socket (make-fluid-selector session:data-socket))
(define session-passive-socket (make-fluid-selector session:passive-socket))
(define set-session-control-input-port
(make-fluid-setter set-session:control-input-port))
(define set-session-control-output-port
(make-fluid-setter set-session:control-output-port))
(define set-session-logged-in? (make-fluid-setter set-session:logged-in?))
(define set-session-authenticated? (make-fluid-setter set-session:authenticated?))
(define set-session-anonymous? (make-fluid-setter set-session:anonymous?))
(define set-session-root-directory (make-fluid-setter set-session:root-directory))
(define set-session-current-directory (make-fluid-setter set-session:current-directory))
(define set-session-to-be-renamed (make-fluid-setter set-session:to-be-renamed))
(define set-session-reverse-replies (make-fluid-setter set-session:reverse-replies))
(define set-session-reply-code (make-fluid-setter set-session:reply-code))
(define set-session-type (make-fluid-setter set-session:type))
(define set-session-data-socket (make-fluid-setter set-session:data-socket))
(define set-session-passive-socket (make-fluid-setter set-session:passive-socket))
(define (make-options-selector selector)
(lambda () (selector (thread-fluid options))))
;(define (make-options-setter setter)
; (lambda (value)
; (setter (thread-fluid options))))
(define options-logfile (make-options-selector options:logfile))
(define options-logfile-lock (make-options-selector options:logfile-lock))
(define options-dns-lookup? (make-options-selector 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 (options-dns-lookup?)
(or (dns-lookup-ip ip)
ip))
ip)))
(lambda (start-transfer-seconds info full-path direction)
(if (options-logfile)
(begin
(obtain-lock (options-logfile-lock))
(format (options-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
(maybe-dns-lookup
(socket-address->string
(socket-remote-address (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 (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 (options-logfile))
(release-lock (options-logfile-lock)))))))
(define (open-logfile 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)~%")
(current-error-port)))
(and logfile
(open-output-file 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 anonymous-home . maybe-args)
(let-optionals maybe-args
((port 21)
(logfile #f)
(dns-lookup? #f))
(let-thread-fluid options
(make-options (open-logfile logfile)
(make-lock)
(and dns-lookup?))
(lambda ()
(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)))))))
(define (spawn-to-handle-connection socket address anonymous-home port remote-address)
(lambda ()
(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 (socket:inport socket)
(socket:outport socket)
(file-name-as-directory anonymous-home)))
(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 anonymous-home . maybe-args)
(let-optionals maybe-args
((logfile #f)
(dns-lookup? #f))
(let-thread-fluid options
(make-options (open-logfile logfile)
(make-lock)
(and dns-lookup?))
(lambda ()
(with-syslog-destination
"ftpd"
#f
#f
#f
(lambda ()
(log (syslog-level notice)
"starting ftpd from inetd"
(expand-file-name anonymous-home (cwd)))
(handle-connection (current-input-port)
(current-output-port)
(file-name-as-directory anonymous-home))))))))
(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 input-port output-port anonymous-home)
(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-fluid session (make-session input-port output-port
anonymous-home)
(lambda ()
(display-banner)
(handle-commands))))))))
(define (display-banner)
(log (syslog-level debug)
"displaying banner (220)")
(register-reply! 220
(string-append
"Scheme Untergrund ftp server ("
*ftpd-version*
") ready.")))
(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 (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
((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-session-logged-in? #t)
(set-session-authenticated? #t)
(set-session-anonymous? #t)
(set-session-root-directory (session-anonymous-home))
(set-session-current-directory "")
(register-reply! 230 "Anonymous user logged in."))
(define (handle-pass password)
(log-command (syslog-level info) "PASS" password)
(cond
((not (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."))
((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 (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 (session-root-directory) current-directory))
(lambda () ; I hate gratuitous syntax
(log (syslog-level debug)
"changing current directory to \"/~A\" (250)"
current-directory)
(set-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 (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 (session-root-directory)
(assemble-path (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-session-to-be-renamed full-path))))
(define (handle-rnto path)
(log-command (syslog-level info) "RNTO" path)
(ensure-authenticated-login)
(if (not (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 (session-root-directory)
(assemble-path (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 (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-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-session-type 'ascii))
((string-ci=? "I" arg)
(log (syslog-level debug) "changed type to image (8-bit binary) (200)")
(set-session-type 'image))
((string-ci=? "L8" arg)
(log (syslog-level debug) "changed type to image (8-bit binary) (200)")
(set-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 (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-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-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)
(call-with-values
(lambda ()
(socket-address->internet-address
(socket-local-address (port->socket (session-control-input-port)
protocol-family/internet))))
(lambda (host-address control-port)
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-list
(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 (session-root-directory)
(assemble-path (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 (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 (session-root-directory)
(assemble-path (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 (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 (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 (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 (session-root-directory)
(assemble-path (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 (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"
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 (session-logged-in?))
(not (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 (session-data-socket))
(not (session-passive-socket)))
(begin
(log (syslog-level debug) "no data connection (425)")
(signal-error! 425 "No data connection.")))
(if (session-passive-socket)
(call-with-values
(lambda () (accept-connection (session-passive-socket)))
(lambda (socket socket-address)
(set-session-data-socket socket))))
(log (syslog-level debug) "opening data connection (150)")
(register-reply! 150 "Opening data connection.")
(write-replies)
(set-socket-option (session-data-socket) level/socket
socket/send-buffer *window-size*)
(set-socket-option (session-data-socket) level/socket
socket/receive-buffer *window-size*))
(define (maybe-close-data-connection)
(if (or (session-data-socket) (session-passive-socket))
(close-data-connection)))
(define (close-data-connection)
(if (session-data-socket)
(close-socket (session-data-socket)))
(if (session-passive-socket)
(close-socket (session-passive-socket)))
(log (syslog-level debug) "closing data connection (226)")
(register-reply! 226 "Closing data connection.")
(set-session-data-socket #f)
(set-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? (session-reverse-replies)))
(let loop ((messages (reverse (session-reverse-replies))))
(if (null? (cdr messages))
(write-final-reply (car messages))
(begin
(write-nonfinal-reply (car messages))
(loop (cdr messages))))))
(set-session-reverse-replies '()))
(define (write-final-reply line)
(format (session-control-output-port) "~D ~A" (session-reply-code) line)
(log (syslog-level debug) "Reply: ~D ~A~%" (session-reply-code) line)
(write-crlf (session-control-output-port))
(force-output (session-control-output-port)))
(define (write-nonfinal-reply line)
(format (session-control-output-port) "~D-~A" (session-reply-code) line)
(log (syslog-level debug) "Reply: ~D-~A~%" (session-reply-code) line)
(write-crlf (session-control-output-port)))
(define (signal-error! code message)
(register-reply! code message)
(signal 'ftpd-error))
(define (register-reply! code message)
(set-session-reverse-replies
(cons message (session-reverse-replies)))
(set-session-reply-code code))
; Version
(define *ftpd-version* "$Revision: 1.8 $")
(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
90000 ; timeout
500)) ; max interval
(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))
; Utilities
;(define (optional maybe-arg default-exp)
; (cond
; ((null? maybe-arg) default-exp)
; ((null? (cdr maybe-arg)) (car maybe-arg))
; (else (error "too many optional arguments" maybe-arg))))