Support passive mode in FTP.

scheme/lib/ftp.scm

@@ -256,32 +256,33 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;;: connection [ x string ] -> status
+
 (define (ftp-ls connection . maybe-dir)
-  (let* ((sock (ftp-open-data-connection connection)))
+  (with-data-connection
-    (ftp-send-command connection
+   connection
-                      (apply build-command "NLST" maybe-dir)
+   (lambda ()
-                      (code-with-prefix "1"))
+     (ftp-send-command connection
-    (receive (newsock newsockaddr)
+		       (apply build-command "NLST" maybe-dir)
-	(accept-connection sock)
+		       (code-with-prefix "1")))
-      (let ((lines (port->lines (socket:inport newsock))))
+   (lambda (data-socket)
-	(close-socket newsock)
+     (port->lines (socket:inport data-socket)))))
-	(close-socket sock)
+
-	(ftp-read-reply connection)
+(define (find-port-arg string)
-	lines))))
+  (cond
+   ((regexp-search (rx (: (+ digit) (= 5 (: #\, (+ digit))))) string)
+    => (lambda (match)
+	 (match:substring match 0)))))
 
 ;;: connection [ x string ] -> status
 (define (ftp-dir connection . maybe-dir)
-  (let* ((sock (ftp-open-data-connection connection)))
+  (with-data-connection
-    (ftp-send-command connection
+   connection
-                      (apply build-command "LIST" maybe-dir)
+   (lambda ()
-                      (code-with-prefix "1"))
+     (ftp-send-command connection
-    (receive (newsock newsockaddr)
+		       (apply build-command "LIST" maybe-dir)
-	(accept-connection sock)
+		       (code-with-prefix "1")))
-      (let ((lines (port->lines (socket:inport newsock))))
+   (lambda (data-socket)
-	(close-socket newsock)
+     (port->lines (socket:inport data-socket)))))
-	(close-socket sock)
-	(ftp-read-reply connection)
-	lines))))
 
 (define (port->lines port)
   (let loop ((reverse-lines '()))
@@ -291,16 +292,14 @@
 	  (loop (cons line reverse-lines))))))
 
 (define (ftp-get connection remote-file act)
-  (let* ((sock (ftp-open-data-connection connection)))
+  (with-data-connection
-    (ftp-send-command connection
+   connection
-		      (build-command "RETR" remote-file)
+   (lambda ()
-                      (exactly-code "150"))
+     (ftp-send-command connection
-    (receive (newsock newsockaddr)
+		       (build-command "RETR" remote-file)
-	(accept-connection sock)
+		       (exactly-code "150")))
-      (act (socket:inport newsock))
+   (lambda (data-socket)
-      (close-socket newsock)
+     (act (socket:inport data-socket)))))
-      (close-socket sock)
-      (ftp-read-reply connection))))
 
 ;; FIXME: should have an optional argument :rename which defaults to
 ;; false, which would make us upload to a temporary name and rename at
@@ -309,24 +308,22 @@
 ;; space on device".
 
 (define (ftp-put connection remote-file act)
-  (let ((sock (ftp-open-data-connection connection)))
+  (with-data-connection
-    (ftp-send-command connection (build-command "STOR" remote-file)
+   connection
-		      (exactly-code "150"))
+   (lambda ()
-    (receive (newsock newsockaddr)
+     (ftp-send-command connection (build-command "STOR" remote-file)
-	(accept-connection sock)
+		       (exactly-code "150")))
-      (act (socket:outport newsock))
+   (lambda (data-socket)
-      (close-socket newsock)
+     (act (socket:outport data-socket)))))
-      (close-socket sock))))
 
 (define (ftp-append connection remote-file act)
-  (let ((sock (ftp-open-data-connection connection)))
+  (with-data-connection
-    (ftp-send-command connection (build-command "APPE" remote-file)
+   connection
-		      (exactly-code "150"))
+   (lambda ()
-    (receive (newsock newsockaddr)
+     (ftp-send-command connection (build-command "APPE" remote-file)
-	(accept-connection sock)
+		       (exactly-code "150"))
-      (act (socket:outport newsock))
+     (lambda (data-socket)
-      (close-socket newsock)
+       (act (socket:outport data-socket))))))
-      (close-socket sock))))
 
 ;; send a command verbatim to the remote server and wait for a
 ;; reply.
@@ -338,21 +335,44 @@
 ;; ------------------------------------------------------------------------
 ;; no exported procedures below
 
-(define (ftp-open-data-connection connection)
+(define (with-data-connection connection command-thunk proc)
-  (let* ((sock (create-socket protocol-family/internet
+  (if (ftp-connection-passive-mode? connection)
-                              socket-type/stream))
+      (let* ((pasv-reply (ftp-send-command connection "PASV" (exactly-code "227")))
-         (sockaddr (internet-address->socket-address
+	     (port-arg (find-port-arg pasv-reply)))
-                    internet-address/any
+	(call-with-values
-                    0)))                ; 0 to accept any port
+	 (lambda () (parse-port-arg port-arg))
-    (set-socket-option sock level/socket socket/reuse-address #t)
+	 (lambda (address port)
-    (set-socket-option sock level/socket socket/linger 120)
+	   (let ((data-socket (create-socket protocol-family/internet
-    (bind-socket sock sockaddr)
+					     socket-type/stream)))
-    (listen-socket sock 0)
+	     (set-socket-option data-socket level/socket socket/reuse-address #t)
-    (ftp-send-command connection        ; send PORT command
+	     (connect-socket data-socket
-                      (ftp-build-PORT-string (socket-local-address sock)))
+			     (internet-address->socket-address
-    sock))
+			      address port))
-
+	     (command-thunk)
+	     (let ((retval (proc data-socket)))
+	       (close-socket data-socket)
+	       (ftp-read-reply connection)
+	       retval)))))
 
+      (let* ((sock (create-socket protocol-family/internet
+				  socket-type/stream))
+	     (sockaddr (internet-address->socket-address
+			internet-address/any
+			0)))                ; 0 to accept any port
+	(set-socket-option sock level/socket socket/reuse-address #t)
+	(set-socket-option sock level/socket socket/linger 120)
+	(bind-socket sock sockaddr)
+	(listen-socket sock 0)
+	(ftp-send-command connection        ; send PORT command
+			  (ftp-build-PORT-string (socket-local-address sock)))
+	(command-thunk)
+	(receive (data-socket data-socket-address)
+	    (accept-connection sock)
+	  (let ((retval (proc data-socket)))
+	    (close-socket data-socket)
+	    (close-socket sock)
+	    (ftp-read-reply connection)
+	    retval)))))
 
 ;; TODO: Unix-specific commands
 ;; SITE UMASK 002

scheme/packages.scm

@@ -427,7 +427,8 @@
 	let-opt
 	sunet-utilities
 	format-net
-	crlf-io)
+	crlf-io
+	ftp-library)
   (files (lib ftp)))
 
 (define-structure netrc netrc-interface