Added tentative support for ftp RESTART command.

This commit is contained in:
tjaden 2003-06-14 12:59:02 +00:00
parent d236b8990f
commit 64a8793a37
1 changed files with 52 additions and 2 deletions

View File

@ -9,7 +9,6 @@
; It doesn't support the following desirable things: ; It doesn't support the following desirable things:
; ;
; - Login by user ; - Login by user
; - RESTART support
; - Banners from files on CWD ; - Banners from files on CWD
; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/ ; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
@ -95,6 +94,7 @@
root-directory root-directory
current-directory current-directory
to-be-renamed to-be-renamed
restart-position
replies replies
reply-code reply-code
type type
@ -117,6 +117,8 @@
set-session-current-directory!) set-session-current-directory!)
(to-be-renamed session-to-be-renamed (to-be-renamed session-to-be-renamed
set-session-to-be-renamed!) set-session-to-be-renamed!)
(restart-position session-restart-position
set-session-restart-position!)
(replies session-replies (replies session-replies
set-session-replies!) set-session-replies!)
(reply-code session-reply-code (reply-code session-reply-code
@ -136,6 +138,7 @@
#f ; root-directory #f ; root-directory
"" ; current-directory "" ; current-directory
#f ; to-be-renamed #f ; to-be-renamed
#f ; restart-position
'() ; replies '() ; replies
#f ; reply-code #f ; reply-code
'ascii ; type 'ascii ; type
@ -166,6 +169,7 @@
(define the-session-root-directory (make-session-selector session-root-directory)) (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-current-directory (make-session-selector session-current-directory))
(define the-session-to-be-renamed (make-session-selector session-to-be-renamed)) (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-replies (make-session-selector session-replies))
(define the-session-reply-code (make-session-selector session-reply-code)) (define the-session-reply-code (make-session-selector session-reply-code))
(define the-session-type (make-session-selector session-type)) (define the-session-type (make-session-selector session-type))
@ -188,6 +192,8 @@
(make-session-modifier set-session-current-directory!)) (make-session-modifier set-session-current-directory!))
(define set-the-session-to-be-renamed! (define set-the-session-to-be-renamed!
(make-session-modifier set-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! (define set-the-session-replies!
(make-session-modifier set-session-replies!)) (make-session-modifier set-session-replies!))
(define set-the-session-reply-code! (define set-the-session-reply-code!
@ -1039,6 +1045,20 @@
(log (syslog-level debug) "closing data connection (226)") (log (syslog-level debug) "closing data connection (226)")
(register-reply! 226 "Closing data connection.")) (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) (define (handle-retr path)
(log-command (syslog-level info) "RETR" path) (log-command (syslog-level info) "RETR" path)
(ensure-authenticated-login) (ensure-authenticated-login)
@ -1066,6 +1086,12 @@
path)))) path))))
(call-with-input-file full-path (call-with-input-file full-path
(lambda (file-port) (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 (with-data-connection
(lambda () (lambda ()
(case (the-session-type) (case (the-session-type)
@ -1089,6 +1115,20 @@
(define (current-seconds) (define (current-seconds)
(receive (time ticks) (time+ticks) time)) (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) (define (handle-stor path)
(log-command (syslog-level info) "STOR" path) (log-command (syslog-level info) "STOR" path)
(ensure-authenticated-login) (ensure-authenticated-login)
@ -1103,8 +1143,17 @@
(signal-error! 550 (format #f "Can't open \"~A\" for writing." path)))) (signal-error! 550 (format #f "Can't open \"~A\" for writing." path))))
(lambda () (lambda ()
(let ((start-transfer-seconds (current-seconds))) (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) (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 (with-data-connection
(lambda () (lambda ()
(let ((inport (socket:inport (the-session-data-socket)))) (let ((inport (socket:inport (the-session-data-socket))))
@ -1233,6 +1282,7 @@
(cons "PASV" handle-pasv) (cons "PASV" handle-pasv)
(cons "NLST" handle-nlst) (cons "NLST" handle-nlst)
(cons "LIST" handle-list) (cons "LIST" handle-list)
(cons "REST" handle-rest)
(cons "RETR" handle-retr) (cons "RETR" handle-retr)
(cons "STOR" handle-stor) (cons "STOR" handle-stor)
(cons "ABOR" handle-abor))) (cons "ABOR" handle-abor)))