From 64a8793a377d30058a4c9ac46266efe6e970c280 Mon Sep 17 00:00:00 2001
From: tjaden <tjaden>
Date: Sat, 14 Jun 2003 12:59:02 +0000
Subject: [PATCH] Added tentative support for ftp RESTART command.

---
 scheme/ftpd/ftpd.scm | 54 ++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 52 insertions(+), 2 deletions(-)

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)))