; RFC 959 ftp daemon ;;; This file is part of the Scheme Untergrund Networking package. ;;; Copyright (c) 1998-2003 by Mike Sperber ;;; 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 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!) (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) (really-make-ftpd-options 21 "~ftp" (list (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-log-port 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-log-port (make-ftpd-options-transformer set-ftpd-options-log-port!)) (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 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 logged-in? authenticated? anonymous? root-directory current-directory to-be-renamed replies reply-code type data-socket passive-socket) session? (control-input-port session-control-input-port set-session-control-input-port!) (control-output-port session-control-output-port set-session-control-output-port!) (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!) (replies session-replies set-session-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!)) (define (make-session input-port output-port) (really-make-session input-port output-port #f ; logged-in? #f ; autenticated? #f ; anonymous? #f ; root-directory "" ; current-directory #f ; to-be-renamed '() ; replies #f ; reply-code 'ascii ; type #f ; data-socket #f ; passive-socket )) (define session (make-fluid #f)) (define server-state (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-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-replies (make-session-selector session-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 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-replies! (make-session-modifier set-session-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 (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 () (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-log-port (make-ftpd-options-selector ftpd-options-log-port)) (define the-ftpd-options-dns-lookup? (make-ftpd-options-selector ftpd-options-dns-lookup?)) ;;; LOG ------------------------------------------------------- (define (log level format-message . args) (syslog level (apply format #f (string-append "(thread ~D) " format-message) (thread-uid (current-thread)) args))) (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 start-transfer-seconds info full-path direction) (if (the-server-state-log-port) (begin (obtain-lock (the-server-state-log-lock)) (format (the-server-state-log-port) "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%" (format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) (- (current-seconds) start-transfer-seconds) (maybe-dns-lookup (socket-address->string (socket-remote-address (the-session-data-socket)) #f)) (file-info:size info) (string-map (lambda (c) (if (eq? c #\space) #\_ c)) full-path) (case (the-session-type) ((ascii) "a") ((image) "b") (else "?")) direction) (force-output (the-server-state-log-port)) (release-lock (the-server-state-log-lock))))) (define (maybe-dns-lookup ip) (if (the-ftpd-options-dns-lookup?) (or (dns-lookup-ip ip) ip) ip)) ;;; 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) (with-syslog-destination "ftpd" #f #f #f (lambda () (log (syslog-level notice) "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))) (let ((the-server-state (make-server-state (ftpd-options-log-port 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 the-server-state))))) (ftpd-options-port ftpd-options)))))) (define (handle-connection-encapsulated ftpd-options socket address remote-address the-server-state) (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) the-server-state)) (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) (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 ;; 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 the-server-state) (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) server-state the-server-state options ftpd-options (lambda () (display-banner) (handle-commands)))))))) (define (display-banner) (log (syslog-level debug) "displaying banner (220)") (apply 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 (exit) (with-handler (lambda (condition more) (cond ((error? condition) (let ((reason (condition-stuff condition))) (log (syslog-level notice) "internal error occurred: ~S (maybe reason: ~S) -- replying and escaping (451)" condition reason) (replace-reply! 451 (format #f "Internal error: ~S" reason)) (exit))) ((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 occurred (maybe reason: ~S)-- escaping" (condition-stuff condition)) (exit)) (else (more)))) (lambda () (with-errno-handler* (lambda (errno packet) (let ((unix-error (car packet))) (log (syslog-level notice) "unix error occurred: ~S -- replying (451) and escaping" unix-error) (replace-reply! 451 (format #f "Unix error: ~A." unix-error)))) (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 (ftpd-parse-port-arg stuff) (with-fatal-error-handler* (lambda (condition more) (log (syslog-level debug) "reporting syntax error in argument (500)") (signal-error! 500 "Syntax error in argument to PORT.")) (lambda () (parse-port-arg stuff)))) (define (handle-port stuff) (log-command (syslog-level info) "PORT" stuff) (ensure-authenticated-login) (maybe-close-data-connection) (call-with-values (lambda () (ftpd-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) (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) (ensure-data-connection) (with-fatal-error-handler* (lambda (condition more) (maybe-close-data-connection)) (lambda () (thunk) (maybe-close-data-connection) (log (syslog-level debug) "closing data connection (226)") (register-reply! 226 "Closing data connection.")))) (define *window-size* 8192) (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))) (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 ; For the nature of the replies, see RFC 959. (define (write-replies) (let ((replies (the-session-replies))) (cond ((null? replies) (error "no reply registered")) (else (let loop ((replies replies)) (if (not (null? replies)) (let ((reply-text (format #f (if (pair? (cdr replies)) "~D-~A" "~D ~A") (the-session-reply-code) (car replies)))) (display reply-text (the-session-control-output-port)) (write-crlf (the-session-control-output-port)) (log (syslog-level debug) "Reply: ~A" reply-text) (loop (cdr replies)))))))) (set-the-session-reply-code! #f)) (define (signal-error! code message) (replace-reply! code message) (signal 'ftpd-error code message)) (define (register-reply! code . messages) (if (the-session-reply-code) (apply error "tried to register more than one reply" code messages (the-session-replies)) (apply replace-reply! code messages))) (define (replace-reply! code . messages) (set-the-session-replies! messages) (set-the-session-reply-code! code))