Improve ftp client. Add upload, progress monitor and something else.

original commit: 4cc287f7e5

collects/net/ftp.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require racket/date racket/file racket/port racket/tcp)
+(require racket/date racket/file racket/port racket/tcp racket/list)
 
 (provide ftp-connection?
          ftp-cd
@@ -8,7 +8,12 @@
          ftp-close-connection
          ftp-directory-list
          ftp-download-file
-         ftp-make-file-seconds)
+         ftp-make-file-seconds
+         ftp-upload-file
+         ftp-delete-file
+         ftp-make-directory
+         ftp-delete-directory
+         ftp-rename-file)
 
 ;; opqaue record to represent an FTP connection:
 (define-struct ftp-connection (in out))
@@ -61,6 +66,9 @@
      [else
       (error 'ftp "unexpected result: ~e" line)])))
 
+(define (bytes->number bytes)
+  (string->number (bytes->string/latin-1 bytes)))
+
 (define (get-month month-bytes)
   (cond [(assoc month-bytes
                 '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
@@ -69,9 +77,6 @@
          => cadr]
         [else (error 'get-month "bad month: ~s" month-bytes)]))
 
-(define (bytes->number bytes)
-  (string->number (bytes->string/latin-1 bytes)))
-
 (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
 
 (define (ftp-make-file-seconds ftp-date-str)
@@ -96,41 +101,44 @@
 
 (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
 
-(define (establish-data-connection tcp-ports)
+(define (establish-data-connection ftp-ports in-or-out)
-  (fprintf (ftp-connection-out tcp-ports) "PASV\r\n")
+  (fprintf (ftp-connection-out ftp-ports) "PASV\r\n")
   (let ([response (ftp-check-response
-                   (ftp-connection-in tcp-ports)
+                   (ftp-connection-in ftp-ports)
-                   (ftp-connection-out tcp-ports)
+                   (ftp-connection-out ftp-ports)
-                   #"227"
+                   #"227" (lambda (s ignore) s) (void))])
-                   (lambda (s ignore) s) ; should be the only response
-                   (void))])
     (let* ([reg-list (regexp-match re:passive response)]
            [pn1 (and reg-list
                      (bytes->number (list-ref reg-list 5)))]
            [pn2 (bytes->number (list-ref reg-list 6))])
       (unless (and reg-list pn1 pn2)
         (error 'ftp "can't understand PASV response: ~e" response))
-      (let-values ([(tcp-data tcp-data-out)
+      (let-values ([(tcp-data-in tcp-data-out)
                     (tcp-connect (format "~a.~a.~a.~a"
                                          (list-ref reg-list 1)
                                          (list-ref reg-list 2)
                                          (list-ref reg-list 3)
                                          (list-ref reg-list 4))
                                  (+ (* 256 pn1) pn2))])
-        (fprintf (ftp-connection-out tcp-ports) "TYPE I\r\n")
+        (fprintf (ftp-connection-out ftp-ports) "TYPE I\r\n")
-        (ftp-check-response (ftp-connection-in tcp-ports)
+        (ftp-check-response (ftp-connection-in ftp-ports)
-                            (ftp-connection-out tcp-ports)
+                            (ftp-connection-out ftp-ports)
                             #"200" void (void))
+        (if (eq? in-or-out 'in)
+            (begin
               (tcp-abandon-port tcp-data-out)
-        tcp-data))))
+              tcp-data-in)
-
+            (begin
-;; Used where version 0.1a printed responses:
+              (tcp-abandon-port tcp-data-in)
-(define (print-msg s ignore)
+              tcp-data-out))))))
-  ;; (printf "~a\n" s)
-  (void))
 
+;; 230? is var. It always keep last line's action result. The lambda in this 
+;; ftp-check-response means:
+;; "if one line's head is 230, then this ftp server do not 
+;; need PASS command. "or 230? (rege..." means if 230? is true already
+;; , then do not check the line anymore, it's just true.
 (define (ftp-establish-connection* in out username password)
-  (ftp-check-response in out #"220" print-msg (void))
+  (ftp-check-response in out #"220" void (void))
   (fprintf out "USER ~a\r\n" username)
   (let ([no-password? (ftp-check-response
                        in out (list #"331" #"230")
@@ -146,13 +154,13 @@
   (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
     (ftp-establish-connection* tcpin tcpout username password)))
 
-(define (ftp-close-connection tcp-ports)
+(define (ftp-close-connection ftp-ports)
-  (fprintf (ftp-connection-out tcp-ports) "QUIT\r\n")
+  (fprintf (ftp-connection-out ftp-ports) "QUIT\r\n")
-  (ftp-check-response (ftp-connection-in tcp-ports)
+  (ftp-check-response (ftp-connection-in ftp-ports)
-                      (ftp-connection-out tcp-ports)
+                      (ftp-connection-out ftp-ports)
                       #"221" void (void))
-  (close-input-port (ftp-connection-in tcp-ports))
+  (close-input-port (ftp-connection-in ftp-ports))
-  (close-output-port (ftp-connection-out tcp-ports)))
+  (close-output-port (ftp-connection-out ftp-ports)))
 
 (define (ftp-cd ftp-ports new-dir)
   (fprintf (ftp-connection-out ftp-ports) "CWD ~a\r\n" new-dir)
@@ -165,19 +173,19 @@
            "^(.)(.*) ((?i:jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)"
            " .* [0-9][0-9]:?[0-9][0-9]) (.*)$")))
 
-(define (ftp-directory-list tcp-ports [path #f])
+(define (ftp-directory-list ftp-ports [path #f])
-  (define tcp-data (establish-data-connection tcp-ports))
+  (define tcp-data (establish-data-connection ftp-ports 'in))
   (if path
-    (fprintf (ftp-connection-out tcp-ports) "LIST ~a\r\n" path)
+    (fprintf (ftp-connection-out ftp-ports) "LIST ~a\r\n" path)
-    (fprintf (ftp-connection-out tcp-ports) "LIST\r\n"))
+    (fprintf (ftp-connection-out ftp-ports) "LIST\r\n"))
-  (ftp-check-response (ftp-connection-in tcp-ports)
+  (ftp-check-response (ftp-connection-in ftp-ports)
-                      (ftp-connection-out tcp-ports)
+                      (ftp-connection-out ftp-ports)
                       (list #"150" #"125") void (void))
   (define lines (port->lines tcp-data))
   (close-input-port tcp-data)
-  (ftp-check-response (ftp-connection-in tcp-ports)
+  (ftp-check-response (ftp-connection-in ftp-ports)
-                      (ftp-connection-out tcp-ports)
+                      (ftp-connection-out ftp-ports)
-                      #"226" print-msg (void))
+                      #"226" void (void))
   (for*/list ([l (in-list lines)]
               [m (in-value (cond [(regexp-match re:dir-line l) => cdr]
                                  [else #f]))]
@@ -189,27 +197,112 @@
     (define r `(,(car m) ,@(cddr m)))
     (if size `(,@r ,size) r)))
 
-(define (ftp-download-file tcp-ports folder filename)
+(define (ftp-download-file ftp-ports folder filename [progress-proc #f])
   ;; Save the file under the name tmp.file, rename it once download is
   ;; complete this assures we don't over write any existing file without
   ;; having a good file down
-  (let* ([tmpfile (make-temporary-file
+  (let* ([tmpfile "file.tmp"]
-                   (string-append
-                    (regexp-replace
-                     #rx"~"
-                     (path->string (build-path folder "ftptmp"))
-                     "~~")
-                    "~a"))]
          [new-file (open-output-file tmpfile #:exists 'replace)]
-         [tcp-data (establish-data-connection tcp-ports)])
+         [tcp-data (establish-data-connection ftp-ports 'in)])
-    (fprintf (ftp-connection-out tcp-ports) "RETR ~a\r\n" filename)
+
-    (ftp-check-response (ftp-connection-in tcp-ports)
+    (transfer-data ftp-ports 'download tcp-data new-file filename progress-proc)
-                        (ftp-connection-out tcp-ports)
+
-                        (list #"125" #"150") print-msg (void))
-    (copy-port tcp-data new-file)
-    (close-output-port new-file)
-    (close-input-port tcp-data)
-    (ftp-check-response (ftp-connection-in tcp-ports)
-                        (ftp-connection-out tcp-ports)
-                        #"226" print-msg (void))
     (rename-file-or-directory tmpfile (build-path folder filename) #t)))
+
+(define (ftp-upload-file ftp-ports filepath [progress-proc #f])
+  (let ([upload-file (open-input-file filepath)]
+        [tcp-data (establish-data-connection ftp-ports 'out)])
+
+    (let ([system-type (system-path-convention-type)]
+          [splitter ""])
+      (if (eq? system-type 'unix)
+          (set! splitter "/")
+          (set! splitter "\\\\"))
+
+      (transfer-data ftp-ports 'upload upload-file tcp-data (last (regexp-split (regexp splitter) filepath)) progress-proc))))
+
+;; download and upload's share part
+(define (transfer-data ftp-ports command from to filename [progress-proc #f])
+  (let ([inner-command ""])
+    (cond
+     [(eq? command 'upload)
+      (set! inner-command "STOR")]
+     [(eq? command 'download)
+      (set! inner-command "RETR")])
+        
+    (fprintf (ftp-connection-out ftp-ports) "~a ~a\r\n" inner-command filename))
+
+  (ftp-check-response (ftp-connection-in ftp-ports)
+                      (ftp-connection-out ftp-ports)
+                      (list #"125" #"150") void (void))
+
+  (let ([rcv-ch (make-channel)]
+        [ctrl-ch (make-channel)]
+        [bytes-tranferred 0])
+
+    (when (procedure? progress-proc)
+      (thread
+       (lambda ()
+         (progress-proc rcv-ch ctrl-ch)))
+
+      (thread
+       (lambda ()
+         (letrec ([loop
+                   (lambda ()
+                     (channel-put rcv-ch bytes-tranferred)
+                     (when (= 0 (channel-get ctrl-ch))
+                       (loop)))])
+           (loop)))))
+
+    (letrec ([loop
+              (lambda (read-from write-to)
+                (let ([bstr (read-bytes 40960 read-from)])
+                  (unless (eof-object? bstr)
+                    (set! bytes-tranferred (+ bytes-tranferred (write-bytes bstr write-to)))
+                    (loop read-from write-to))))])
+
+      (loop from to))
+    
+    (when (procedure? progress-proc)
+      ; stop receiver thread
+      (channel-put rcv-ch bytes-tranferred)
+      (channel-get ctrl-ch)
+      (channel-put rcv-ch -1)
+      
+      ; stop sender thread
+      (channel-get rcv-ch)
+      (channel-put ctrl-ch -1)))
+
+  (close-input-port from)
+  (close-output-port to)
+  (ftp-check-response (ftp-connection-in ftp-ports)
+                      (ftp-connection-out ftp-ports)
+                      #"226" void (void)))
+
+(define (ftp-delete-file ftp-ports filepath)
+  (fprintf (ftp-connection-out ftp-ports) "DELE ~a\r\n" filepath)
+  (ftp-check-response (ftp-connection-in ftp-ports)
+                      (ftp-connection-out ftp-ports)
+                      #"250" void (void)))
+
+(define (ftp-make-directory ftp-ports dirname)
+  (fprintf (ftp-connection-out ftp-ports) "MKD ~a\r\n" dirname)
+  (ftp-check-response (ftp-connection-in ftp-ports)
+                      (ftp-connection-out ftp-ports)
+                      #"257" void (void)))
+
+(define (ftp-delete-directory ftp-ports dirname)
+  (fprintf (ftp-connection-out ftp-ports) "RMD ~a\r\n" dirname)
+  (ftp-check-response (ftp-connection-in ftp-ports)
+                      (ftp-connection-out ftp-ports)
+                      #"250" void (void)))
+
+(define (ftp-rename-file ftp-ports origin dest)
+  (fprintf (ftp-connection-out ftp-ports) "RNFR ~a\r\n" origin)
+  (ftp-check-response (ftp-connection-in ftp-ports)
+                      (ftp-connection-out ftp-ports)
+                      #"350" void (void))
+  (fprintf (ftp-connection-out ftp-ports) "RNTO ~a\r\n" dest)
+  (ftp-check-response (ftp-connection-in ftp-ports)
+                      (ftp-connection-out ftp-ports)
+                      #"250" void (void)))

collects/net/scribblings/ftp.scrbl

@@ -1,12 +1,14 @@
 #lang scribble/doc
 @(require "common.rkt" (for-label net/ftp net/ftp-unit net/ftp-sig))
 
-@title[#:tag "ftp"]{FTP: Client Downloading}
+@title[#:tag "ftp"]{FTP: Client}
+
+@author["Micah Flatt"
+        (author+email "Chen Xiao" "chenxiao770117@gmail.com")]
 
 @defmodule[net/ftp]{The @racketmodname[net/ftp] library provides
-utilities for FTP client operations.
+utilities for FTP client operations.}
 
-The library was written by Micah Flatt.}
 
 @section[#:tag "ftp-procs"]{Functions}
 
@@ -76,13 +78,64 @@ this information can be unreliable.}
 
 @defproc[(ftp-download-file [ftp-conn ftp-connection?]
                             [local-dir path-string?]
-                            [file string?]) void?]{
+                            [file string?]
+                            [progress-proc procedure? #f]) void?]{
 
 Downloads @racket[file] from the server's current directory and puts
 it in @racket[local-dir] using the same name. If the file already
 exists in the local directory, it is replaced, but only after the
 transfer succeeds (i.e., the file is first downloaded to a temporary
-file, then moved into place on success).}
+file, then moved into place on success).
+
+@racket[progress-proc] is a @racket[(-> channel? channel? any?)], means @racket[(progress-proc receive-channel control-channel)].
+Inside the @racket[progress-proc], use @racket[(channel-get receive-channel)] to get bytes count has downloaded(uploaded).
+After @racket[(channel-get receive-channel)], use @racket[(channel-put control-channel 0)] to launch sender to get a new bytes count.
+
+@racket[-1] means "transfer completed" @racket[0] means "normal"
+
+Warning: Do something between get and put, not "refresh too fast", this will slow down the transfer speed.
+
+@racket[Example:]
+
+@racketblock[
+(ftp-download-file 
+   ftp-conn "." "testfile"
+   (lambda (rcv-ch ctrl-ch)
+     (letrec ([loop
+       (lambda ()
+         (let ([data (channel-get rcv-ch)])
+           (unless (= data -1)
+             (channel-put ctrl-ch 0)
+             (printf "[~a] bytes has downloaded~%" data)
+             (loop))))])
+       (loop))))]
+}
+
+@defproc[(ftp-upload-file [ftp-conn ftp-connection?]
+                          [file-path path-string?]
+                          [progress-proc procedure? #f]) void?]{
+
+Upload @racket[file-path] to the server's current directory using the same name. 
+If the file already exists in the local directory, it is replaced.
+@racket[progress-proc] usage is same as @racket[ftp-download-file].}
+
+@defproc[(ftp-delete-file [ftp-conn ftp-connection?]
+                          [file-path path-string?]) void?]{
+Delete the remote file use the @racket[file-path] on the server.}
+
+@defproc[(ftp-make-directory [ftp-conn ftp-connection?]
+                             [dir-name string?]) void?]{
+Make remote directory use the @racket[dir-name].}
+
+@defproc[(ftp-delete-directory [ftp-conn ftp-connection?]
+                               [dir-name string?]) void?]{
+Delete remote directory use the @racket[dir-name].}
+
+@defproc[(ftp-rename-file [ftp-conn ftp-connection?]
+                          [origin string?]
+                          [dest string?]) void?]{
+Rename remote file name from @racket[origin] to @racket[dest].}
+
 
 @; ----------------------------------------
 

collects/tests/net/ftp.rkt

@@ -28,7 +28,8 @@
   (define cop (open-output-string))
   (define-values [pasv1-thd pasv1-port] (tcp-serve* (current-output-port) DIRLIST))
   (define-values [pasv2-thd pasv2-port] (tcp-serve* (current-output-port) TEXT-FILE))
-  (define-values [main-thd main-port] (tcp-serve cop (SERVER-OUTPUT pasv1-port pasv2-port)))
+  (define-values [pasv3-thd pasv3-port] (tcp-serve* (open-output-nowhere) TEXT-FILE))
+  (define-values [main-thd main-port] (tcp-serve cop (SERVER-OUTPUT pasv1-port pasv2-port pasv3-port)))
   (define server "127.0.0.1")
   (define port main-port)
   (define user "anonymous")
@@ -46,11 +47,17 @@
                   (match-define (list* type ftp-date name ?size) f)
                   (test (ftp-make-file-seconds ftp-date)))
                 (ftp-download-file conn tmp-dir pth)
+                (ftp-upload-file conn (path->string (build-path tmp-dir pth)))
+                (ftp-delete-file conn "3dldf/test.file")
+                (ftp-make-directory conn "test")
+                (ftp-delete-directory conn "test")
+                (ftp-rename-file conn "test1" "test2")
                 (ftp-close-connection conn)
                 (delete-file (build-path tmp-dir pth))
                 (delete-directory/files tmp-dir)
                 (thread-wait pasv1-thd)
                 (thread-wait pasv2-thd)
+                (thread-wait pasv3-thd)
                 (thread-wait main-thd)
                 (get-output-string cop) => EXPECTED-USER-OUTPUT
                 ))))
@@ -176,7 +183,7 @@
   Thank You!
   @||})
 
-(define (SERVER-OUTPUT pasv1-port pasv2-port)
+(define (SERVER-OUTPUT pasv1-port pasv2-port pasv3-port)
   @S{220 GNU FTP server ready.
      230-Due to U.S. Export Regulations, all cryptographic software on this
      230-site is subject to the following legal notice:
@@ -220,6 +227,15 @@
      200 Switching to Binary mode.
      150 Opening BINARY mode data connection for =README-about-.diff-files (745 bytes).
      226 File send OK.
+     227 Entering Passive Mode (127,0,0,1,@pasv3-port)
+     200 Switching to Binary mode.
+     150 Opening BINARY mode data connection for =README-about-.diff-files (745 bytes).
+     226 File send OK.
+     250 Delete operation successful.
+     257 test created
+     250 Remove directory operation successful.
+     350 Ready for RNTO.
+     250 Rename successful.
      221 Goodbye.
      @||})
 
@@ -233,5 +249,13 @@
      PASV
      TYPE I
      RETR =README-about-.diff-files
+     PASV
+     TYPE I
+     STOR =README-about-.diff-files
+     DELE 3dldf/test.file
+     MKD test
+     RMD test
+     RNFR test1
+     RNTO test2
      QUIT
      @||})