diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm index 764464d..4354fe6 100644 --- a/scheme/ftpd/ftpd.scm +++ b/scheme/ftpd/ftpd.scm @@ -9,7 +9,6 @@ ; 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/ @@ -95,6 +94,7 @@ root-directory current-directory to-be-renamed + restart-position replies reply-code type @@ -117,6 +117,8 @@ set-session-current-directory!) (to-be-renamed session-to-be-renamed set-session-to-be-renamed!) + (restart-position session-restart-position + set-session-restart-position!) (replies session-replies set-session-replies!) (reply-code session-reply-code @@ -136,6 +138,7 @@ #f ; root-directory "" ; current-directory #f ; to-be-renamed + #f ; restart-position '() ; replies #f ; reply-code 'ascii ; type @@ -166,6 +169,7 @@ (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-restart-position (make-session-selector session-restart-position)) (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)) @@ -188,6 +192,8 @@ (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-restart-position! + (make-session-modifier set-session-restart-position!)) (define set-the-session-replies! (make-session-modifier set-session-replies!)) (define set-the-session-reply-code! @@ -1039,6 +1045,20 @@ (log (syslog-level debug) "closing data connection (226)") (register-reply! 226 "Closing data connection.")) +(define (handle-rest restart-position) + (log-command (syslog-level info) "REST" restart-position) + (ensure-authenticated-login) + (cond ((string->number restart-position) => + (lambda (restart-position) + (log-command (syslog-level debug) + "REST-command accepted, waiting for RETR or STOR (350)") + (register-reply! + 350 + (format #f "Restarting at ~A. Gimme RETR or STOR next." restart-position)) + (set-the-session-restart-position! restart-position))) + (else + (register-reply! 501 "REST requires a value greater than or equal to 0.")))) + (define (handle-retr path) (log-command (syslog-level info) "RETR" path) (ensure-authenticated-login) @@ -1066,6 +1086,12 @@ path)))) (call-with-input-file full-path (lambda (file-port) + (cond ((the-session-restart-position) => + (lambda (restart-position) + (log (syslog-level debug) "clearing RESTART position") + (set-the-session-restart-position! #f) + (seek file-port restart-position) + (log (syslog-level debug) "seeking for RESTART successful")))) (with-data-connection (lambda () (case (the-session-type) @@ -1089,6 +1115,20 @@ (define (current-seconds) (receive (time ticks) (time+ticks) time)) +; Adapted from CALL-WITH-MUMBLE-FILE in scsh/newports.scm +; Is DYNAMIC-WIND really needed for this case? +(define (call-with-output-file/flags string flags proc) + (let ((port #f)) + (dynamic-wind (lambda () + (if port + (warn "throwing back into a call-with-output-file/flags" + string) + (set! port (open-output-file string flags)))) + (lambda () (proc port)) + (lambda () + (if port + (close port)))))) + (define (handle-stor path) (log-command (syslog-level info) "STOR" path) (ensure-authenticated-login) @@ -1103,8 +1143,17 @@ (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 + (call-with-output-file/flags full-path + (if (the-session-restart-position) + (bitwise-ior open/create) + (bitwise-ior open/create open/truncate)) (lambda (file-port) + (cond ((the-session-restart-position) => + (lambda (restart-position) + (log (syslog-level debug) "clearing RESTART position") + (set-the-session-restart-position! #f) + (seek file-port restart-position) + (log (syslog-level debug) "seeking for RESTART successful")))) (with-data-connection (lambda () (let ((inport (socket:inport (the-session-data-socket)))) @@ -1233,6 +1282,7 @@ (cons "PASV" handle-pasv) (cons "NLST" handle-nlst) (cons "LIST" handle-list) + (cons "REST" handle-rest) (cons "RETR" handle-retr) (cons "STOR" handle-stor) (cons "ABOR" handle-abor)))