From 7d3c1ddf6fc1b6f7e107ac2e745c4735339e284b Mon Sep 17 00:00:00 2001 From: sperber Date: Sat, 8 Jun 2002 15:07:55 +0000 Subject: [PATCH] Moved to ftpd subdirectory. --- ftpd.scm | 1269 ------------------------------------------------------ 1 file changed, 1269 deletions(-) delete mode 100644 ftpd.scm diff --git a/ftpd.scm b/ftpd.scm deleted file mode 100644 index c10edde..0000000 --- a/ftpd.scm +++ /dev/null @@ -1,1269 +0,0 @@ -; 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/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 *logfile* #f) ; file-port to log to like wu-ftpd (analyzable with webalizer) - -(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))))) - -;; 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 ((file-log-lock (make-lock))) - (lambda (start-transfer-seconds info full-path direction) - (if *logfile* - (begin - (obtain-lock file-log-lock) - (format *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 - (socket-address->string (socket-remote-address (session-data-socket)) #f) ; remote host name - (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 *logfile*) - (release-lock file-log-lock)))))) - -;;; 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 . with-port?) - (let ((with-port? (optional with-port? #t))) - (receive (host-address service-port) - (socket-address->internet-address socket-address) - (if with-port? - (format #f "~A:~A" - (format-internet-host-address host-address) - (format-port service-port)) - (format #f "~A" - (format-internet-host-address host-address)))))) - -;;; ftpd ------------------------------------------------------- - -(define (ftpd anonymous-home . maybe-args) - (let-optionals - maybe-args - ((port 21) - (logfile #f)) - - (if logfile - (set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append)))) - (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-logfile) - (let ((logfile (optional maybe-logfile))) - (with-errno-handler - ((errno packet) - (else - (format (current-error-port) "[ftpd] Warning: Unable to write logs to ~S. Logging is now made to (current-error-port).~%[ftpd] (To disable logging at all, either leave the logfile argument or give #f as logfile)~%") - (set! *logfile* (current-error-port)))) - (if logfile - (set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append)))))) - - (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, output port ~A and home ~A" - input-port - output-port - anonymous-home) - (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 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))) - (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 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)) - (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 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))))) - (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))) - -(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.38 $") - -(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))))