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
+   connection
+   (lambda ()
      (ftp-send-command connection
 		       (apply build-command "NLST" maybe-dir)
-                      (code-with-prefix "1"))
-    (receive (newsock newsockaddr)
-	(accept-connection sock)
-      (let ((lines (port->lines (socket:inport newsock))))
-	(close-socket newsock)
-	(close-socket sock)
-	(ftp-read-reply connection)
-	lines))))
+		       (code-with-prefix "1")))
+   (lambda (data-socket)
+     (port->lines (socket:inport data-socket)))))
+
+(define (find-port-arg string)
+  (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
+   connection
+   (lambda ()
      (ftp-send-command connection
 		       (apply build-command "LIST" maybe-dir)
-                      (code-with-prefix "1"))
-    (receive (newsock newsockaddr)
-	(accept-connection sock)
-      (let ((lines (port->lines (socket:inport newsock))))
-	(close-socket newsock)
-	(close-socket sock)
-	(ftp-read-reply connection)
-	lines))))
+		       (code-with-prefix "1")))
+   (lambda (data-socket)
+     (port->lines (socket:inport data-socket)))))
 
 (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
+   connection
+   (lambda ()
      (ftp-send-command connection
 		       (build-command "RETR" remote-file)
-                      (exactly-code "150"))
-    (receive (newsock newsockaddr)
-	(accept-connection sock)
-      (act (socket:inport newsock))
-      (close-socket newsock)
-      (close-socket sock)
-      (ftp-read-reply connection))))
+		       (exactly-code "150")))
+   (lambda (data-socket)
+     (act (socket:inport data-socket)))))
 
 ;; 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
+   connection
+   (lambda ()
      (ftp-send-command connection (build-command "STOR" remote-file)
-		      (exactly-code "150"))
-    (receive (newsock newsockaddr)
-	(accept-connection sock)
-      (act (socket:outport newsock))
-      (close-socket newsock)
-      (close-socket sock))))
+		       (exactly-code "150")))
+   (lambda (data-socket)
+     (act (socket:outport data-socket)))))
 
 (define (ftp-append connection remote-file act)
-  (let ((sock (ftp-open-data-connection connection)))
+  (with-data-connection
+   connection
+   (lambda ()
      (ftp-send-command connection (build-command "APPE" remote-file)
 		       (exactly-code "150"))
-    (receive (newsock newsockaddr)
-	(accept-connection sock)
-      (act (socket:outport newsock))
-      (close-socket newsock)
-      (close-socket sock))))
+     (lambda (data-socket)
+       (act (socket:outport data-socket))))))
 
 ;; send a command verbatim to the remote server and wait for a
 ;; reply.
@@ -338,7 +335,25 @@
 ;; ------------------------------------------------------------------------
 ;; no exported procedures below
 
-(define (ftp-open-data-connection connection)
+(define (with-data-connection connection command-thunk proc)
+  (if (ftp-connection-passive-mode? connection)
+      (let* ((pasv-reply (ftp-send-command connection "PASV" (exactly-code "227")))
+	     (port-arg (find-port-arg pasv-reply)))
+	(call-with-values
+	 (lambda () (parse-port-arg port-arg))
+	 (lambda (address port)
+	   (let ((data-socket (create-socket protocol-family/internet
+					     socket-type/stream)))
+	     (set-socket-option data-socket level/socket socket/reuse-address #t)
+	     (connect-socket data-socket
+			     (internet-address->socket-address
+			      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
@@ -350,9 +365,14 @@
 	(listen-socket sock 0)
 	(ftp-send-command connection        ; send PORT command
 			  (ftp-build-PORT-string (socket-local-address sock)))
-    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