; RFC 959 ftp daemon ; Mike Sperber ; Copyright (c) 1998 Michael Sperber. ; 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-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. (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 (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)) ;;; 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))))) ;;; 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))) (define (socket-address->string socket-address) (call-with-values (lambda () (socket-address->internet-address socket-address)) (lambda (host-address service-port) (format #f "~A:~A" (format-internet-host-address host-address) (format-port service-port))))) ;;; ftpd ------------------------------------------------------- (define (ftpd anonymous-home . maybe-port) (let ((port (optional maybe-port 21))) (with-syslog-destination "ftpd" #f #f #f (lambda () (log (syslog-level notice) "starting daemon on port ~D with ~S as anonymous home" port (expand-file-name anonymous-home (cwd))) (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) remote-address))) ; use remote address as thread-name 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) (cond ;; I dunno why SHUTDOWN-SOCKET can die this way, but it ;; can and does ((or (= errno errno/notconn) ;; this one can come out of SOCKET->STRING (= errno errno/inval)) (log (syslog-level notice) "socket to ~A not connected any more - exiting thread" remote-address) (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) (handle-connection (socket:inport socket) (socket:outport socket) (file-name-as-directory anonymous-home)) (log (syslog-level debug) "shutting down socket ~S" socket-string) (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) (with-syslog-destination "ftpd" #f #f #f (lambda () (log (syslog-level notice) "new connection on current input- and output-port with ~S as anonymous home" (expand-file-name anonymous-home (cwd))) (log (syslog-level debug) "inport: ~A, outport: ~A" (current-input-port) (current-output-port)) (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. (set-port-buffering (socket:outport socket) bufpol/none) (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, outputport ~A and home ~A" input-port output-port anonymous-home) (call-with-current-continuation (lambda (escape) (with-handler (lambda (condition more) (log (syslog-level debug) "hit error condition ~A (maybe reason (maybe Netscape?): ~S) -- exiting" (condition-type condition) (condition-stuff condition)) (display condition (current-error-port)) (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 timeliimit 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 as user has not logged in yet. (530)") (register-reply! 530 "You have not logged in yet.")) ((session-anonymous?) (log (syslog-level info) "Accepting password as 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 info) "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 info) "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 info) "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 info) "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 info) "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 info) "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 info) "~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 info) "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 info) "changed type to ascii (200)") (set-session-type 'ascii)) ((string-ci=? "I" arg) (log (syslog-level info) "changed type to image (8-bit binary) (200)") (set-session-type 'image)) ((string-ci=? "L8" arg) (log (syslog-level info) "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 info) "(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 info) "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 info) "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 info) "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))) (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 info) "closing data connection (226)") (register-reply! 226 "Closing data connection.")) (define (handle-retr path) (log-command (syslog-level info) "RETR") (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))) (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 info) "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 info) "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)))))))))))))) (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 () (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)))))))))))) (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 (trim-spaces line)) (split-position (string-index line #\space))) (if split-position (values (upcase-string (substring line 0 split-position)) (trim-spaces (substring line (+ 1 split-position) (string-length line)))) (values (upcase-string 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) ;; (format #t "Reply: ~D ~A~%" (session-reply-code) line) (write-crlf (session-control-output-port))) (define (write-nonfinal-reply line) (format (session-control-output-port) "~D-~A" (session-reply-code) line) ;; (format #t "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.27 $") (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))))