From 4cc287f7e54c35ab4a5c9b358578a9535aaf1438 Mon Sep 17 00:00:00 2001 From: Chenxiao Date: Thu, 13 Dec 2012 16:37:49 +0800 Subject: [PATCH] Improve ftp client. Add upload, progress monitor and something else. --- collects/net/ftp-sig.rkt | 5 + collects/net/ftp.rkt | 209 +++++++++++++++++++++-------- collects/net/scribblings/ftp.scrbl | 63 ++++++++- collects/tests/net/ftp.rkt | 28 +++- 4 files changed, 240 insertions(+), 65 deletions(-) diff --git a/collects/net/ftp-sig.rkt b/collects/net/ftp-sig.rkt index 9572594234..8b2c508266 100644 --- a/collects/net/ftp-sig.rkt +++ b/collects/net/ftp-sig.rkt @@ -7,3 +7,8 @@ ftp-close-connection ftp-directory-list ftp-download-file ftp-make-file-seconds +ftp-upload-file +ftp-delete-file +ftp-make-directory +ftp-delete-directory +ftp-rename-file diff --git a/collects/net/ftp.rkt b/collects/net/ftp.rkt index 6702448612..c9f7ebf6f3 100644 --- a/collects/net/ftp.rkt +++ b/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) - (fprintf (ftp-connection-out tcp-ports) "PASV\r\n") +(define (establish-data-connection ftp-ports in-or-out) + (fprintf (ftp-connection-out ftp-ports) "PASV\r\n") (let ([response (ftp-check-response - (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"227" - (lambda (s ignore) s) ; should be the only response - (void))]) + (ftp-connection-in ftp-ports) + (ftp-connection-out ftp-ports) + #"227" (lambda (s ignore) s) (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") - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) + (fprintf (ftp-connection-out ftp-ports) "TYPE I\r\n") + (ftp-check-response (ftp-connection-in ftp-ports) + (ftp-connection-out ftp-ports) #"200" void (void)) - (tcp-abandon-port tcp-data-out) - tcp-data)))) - -;; Used where version 0.1a printed responses: -(define (print-msg s ignore) - ;; (printf "~a\n" s) - (void)) + (if (eq? in-or-out 'in) + (begin + (tcp-abandon-port tcp-data-out) + tcp-data-in) + (begin + (tcp-abandon-port tcp-data-in) + tcp-data-out)))))) +;; 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) - (fprintf (ftp-connection-out tcp-ports) "QUIT\r\n") - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) +(define (ftp-close-connection ftp-ports) + (fprintf (ftp-connection-out ftp-ports) "QUIT\r\n") + (ftp-check-response (ftp-connection-in ftp-ports) + (ftp-connection-out ftp-ports) #"221" void (void)) - (close-input-port (ftp-connection-in tcp-ports)) - (close-output-port (ftp-connection-out tcp-ports))) + (close-input-port (ftp-connection-in ftp-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 tcp-data (establish-data-connection tcp-ports)) +(define (ftp-directory-list ftp-ports [path #f]) + (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 tcp-ports) "LIST\r\n")) - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) + (fprintf (ftp-connection-out ftp-ports) "LIST ~a\r\n" path) + (fprintf (ftp-connection-out ftp-ports) "LIST\r\n")) + (ftp-check-response (ftp-connection-in ftp-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-connection-out tcp-ports) - #"226" print-msg (void)) + (ftp-check-response (ftp-connection-in ftp-ports) + (ftp-connection-out ftp-ports) + #"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 - (string-append - (regexp-replace - #rx"~" - (path->string (build-path folder "ftptmp")) - "~~") - "~a"))] + (let* ([tmpfile "file.tmp"] [new-file (open-output-file tmpfile #:exists 'replace)] - [tcp-data (establish-data-connection tcp-ports)]) - (fprintf (ftp-connection-out tcp-ports) "RETR ~a\r\n" filename) - (ftp-check-response (ftp-connection-in tcp-ports) - (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)) + [tcp-data (establish-data-connection ftp-ports 'in)]) + + (transfer-data ftp-ports 'download tcp-data new-file filename progress-proc) + (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))) diff --git a/collects/net/scribblings/ftp.scrbl b/collects/net/scribblings/ftp.scrbl index 1bbcaf0387..da3fcd6f36 100644 --- a/collects/net/scribblings/ftp.scrbl +++ b/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].} + @; ---------------------------------------- diff --git a/collects/tests/net/ftp.rkt b/collects/tests/net/ftp.rkt index 940a74fc6d..06b7d273c5 100644 --- a/collects/tests/net/ftp.rkt +++ b/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 @||})