e0de33a005
The revised protocol for a progress procedure doesn't create the thread automatically, and it provides an event to indicate when the progress count changes.
271 lines
13 KiB
Racket
271 lines
13 KiB
Racket
#lang at-exp racket/base
|
|
|
|
(require net/ftp tests/eli-tester
|
|
racket/tcp racket/port racket/file racket/match)
|
|
|
|
(define (tcp-serve dest text)
|
|
(define listener (tcp-listen 0))
|
|
(define the-port (let-values ([(_1 p _2 _3) (tcp-addresses listener #t)]) p))
|
|
(define (feed in out)
|
|
(if (input-port? in) (copy-port in out) (display in out))
|
|
(flush-output out))
|
|
(define (feeder)
|
|
(define-values [ip op] (tcp-accept listener))
|
|
(for-each thread-wait
|
|
(list (thread (λ () (feed text op) (close-output-port op)))
|
|
(thread (λ () (feed ip dest) (close-input-port ip))))))
|
|
(values (thread feeder) the-port))
|
|
|
|
(define (port->splitstr n)
|
|
(let-values ([(q r) (quotient/remainder n 256)]) (format "~a,~a" q r)))
|
|
(define (tcp-serve* dest text)
|
|
(define-values [thd port] (tcp-serve dest text))
|
|
(values thd (port->splitstr port)))
|
|
|
|
(define ((progress-proc dir) get-count)
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(define-values (count changed-evt) (get-count))
|
|
(printf "~a bytes ~aloaded\n" count dir)
|
|
(sync changed-evt)
|
|
(loop)))))
|
|
|
|
(provide tests)
|
|
(module+ main (tests))
|
|
(define (tests)
|
|
(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 [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")
|
|
(define passwd "nonny")
|
|
(define conn #f)
|
|
(define pth "=README-about-.diff-files")
|
|
(define tmp-dir (make-temporary-file "racket-ftp-test-~a" 'directory))
|
|
(test (port->splitstr 18291) => "71,115"
|
|
(ftp-connection? 1) => #f
|
|
(set! conn (ftp-establish-connection server port user passwd))
|
|
(ftp-connection? conn)
|
|
(when (ftp-connection? conn)
|
|
(test (ftp-cd conn "gnu")
|
|
(for ([f (in-list (ftp-directory-list conn))])
|
|
(match-define (list* type ftp-date name ?size) f)
|
|
(test (ftp-make-file-seconds ftp-date)))
|
|
(ftp-download-file conn tmp-dir pth #:progress (progress-proc "down"))
|
|
(ftp-upload-file conn (path->string (build-path tmp-dir pth)) #:progress (progress-proc "up"))
|
|
(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
|
|
))))
|
|
|
|
(define S string-append)
|
|
|
|
(define DIRLIST @S{
|
|
drwxr-xr-x 2 1003 1003 4096 Jan 16 2004 3dldf
|
|
-rw-r--r-- 1 1003 65534 1492 Jan 25 2001 =README
|
|
-rw-r--r-- 1 1003 65534 745 Mar 20 1997 =README-about-.diff-files
|
|
-rw-r--r-- 1 1003 65534 1042 Jan 08 2000 =README-about-.gz-files
|
|
drwxrwxr-x 3 0 1003 4096 Feb 08 2005 GNUinfo
|
|
drwxrwsr-x 3 0 1003 4096 Aug 14 2003 GNUsBulletins
|
|
drwxrwxr-x 2 0 1003 4096 Mar 25 18:42 Licenses
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 MailingListArchives
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 MicrosPorts
|
|
-rw-r--r-- 1 1003 65534 29107 May 03 1998 ProgramIndex
|
|
-rw-r--r-- 1 1003 65534 257 Jun 12 2000 README.DESCRIPTIONS
|
|
drwxrwxr-x 2 0 1003 4096 Dec 29 2007 a2ps
|
|
drwxrwxr-x 2 0 1003 4096 Feb 12 16:45 acct
|
|
drwxrwxr-x 2 0 1003 4096 Jun 09 2006 adns
|
|
drwxr-xr-x 2 1003 1003 4096 Jul 14 2008 aeneas
|
|
drwxrwxr-x 2 0 1003 4096 Dec 20 2008 anubis
|
|
drwxr-xr-x 2 1003 1003 4096 Feb 24 00:20 archimedes
|
|
drwxrwxr-x 4 0 1003 4096 Apr 16 2008 aspell
|
|
lrwxr-xr-x 1 0 0 15 Mar 11 2005 aspell-dict-csb -> aspell/dict/csb
|
|
lrwxrwxrwx 1 0 0 14 Nov 24 2003 aspell-dict-ga -> aspell/dict/ga
|
|
lrwxrwxrwx 1 0 0 14 Mar 22 2004 aspell-dict-hr -> aspell/dict/hr
|
|
lrwxrwxrwx 1 0 0 14 Mar 12 2004 aspell-dict-is -> aspell/dict/is
|
|
lrwxrwxrwx 1 0 0 14 Nov 24 2003 aspell-dict-it -> aspell/dict/it
|
|
lrwxrwxrwx 1 0 0 14 Apr 26 2004 aspell-dict-sk -> aspell/dict/sk
|
|
drwxrwxr-x 13 0 1003 8192 Jul 03 14:05 auctex
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 18:10 autoconf
|
|
drwxr-xr-x 2 1003 1003 4096 Jul 06 14:30 autoconf-archive
|
|
drwxrwxr-x 32 0 1003 4096 Jul 25 18:10 autogen
|
|
drwxrwxr-x 2 0 1003 8192 Dec 08 2009 automake
|
|
drwxrwxr-x 2 0 1003 4096 Aug 26 2007 avl
|
|
drwxr-xr-x 2 1003 1003 4096 Jul 15 2009 ballandpaddle
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 barcode
|
|
drwxrwxr-x 8 0 1003 4096 Jan 18 2010 bash
|
|
drwxrwxr-x 3 0 1003 8192 Jan 18 2007 bayonne
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 bc
|
|
drwxrwxr-x 2 0 1003 4096 Mar 03 15:25 binutils
|
|
drwxrwxr-x 2 0 1003 4096 Aug 06 02:25 bison
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 bool
|
|
drwxr-xr-x 10 1003 1003 4096 Jul 30 2007 bpel2owfn
|
|
-rw-r--r-- 1 1003 65534 420 Nov 15 2000 brl.README
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 calc
|
|
drwxrwxr-x 2 0 1003 4096 Dec 16 2008 ccaudio
|
|
drwxrwxr-x 2 0 1003 4096 Oct 25 2009 ccrtp
|
|
drwxrwxr-x 2 0 1003 8192 May 19 00:50 ccscript
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 cfengine
|
|
drwxr-xr-x 2 1003 1003 4096 Jul 11 2009 cflow
|
|
drwxrwxr-x 2 0 1003 4096 Nov 14 2009 cgicc
|
|
drwxrwxr-x 2 0 1003 4096 Jan 12 2004 chess
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 cim
|
|
drwxrwxr-x 2 0 1003 4096 Mar 25 17:25 classpath
|
|
drwxrwxr-x 2 0 1003 4096 Apr 28 2007 classpathx
|
|
drwxrwxr-x 6 0 1003 4096 Jul 07 17:30 clisp
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 clx
|
|
drwxr-xr-x 2 1003 1003 4096 Jun 05 2004 combine
|
|
lrwxrwxrwx 1 0 0 9 Nov 18 2003 commonc++ -> commoncpp
|
|
drwxrwxr-x 2 0 1003 8192 Aug 11 06:30 commoncpp
|
|
drwxrwxr-x 2 0 1003 4096 Feb 13 2008 config
|
|
drwxrwxr-x 2 0 1003 8192 Apr 23 16:45 coreutils
|
|
drwxrwxr-x 2 0 1003 4096 Mar 10 13:20 cpio
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 cpp2html
|
|
drwxr-xr-x 2 1003 1003 4096 Mar 18 06:45 cppi
|
|
drwxr-xr-x 2 1003 1003 4096 Apr 11 2009 cssc
|
|
drwxrwxr-x 2 0 1003 4096 Feb 21 2008 dap
|
|
-rw-r--r-- 1 1003 65534 110 Jun 06 1999 dc.README
|
|
drwxrwxr-x 2 0 1003 4096 Feb 11 2009 ddd
|
|
drwxr-xr-x 2 1003 1003 4096 Apr 06 18:50 ddrescue
|
|
drwxrwxr-x 2 0 1003 4096 Jan 30 2004 dejagnu
|
|
drwxr-xr-x 2 1003 1003 4096 Jul 07 20:50 denemo
|
|
-rw-r--r-- 1 1003 65534 145 May 22 2001 dia.README
|
|
drwxr-xr-x 2 1003 1003 4096 Jul 07 19:35 dico
|
|
drwxrwxr-x 2 0 1003 4096 Sep 17 2007 diction
|
|
-rw-r--r-- 1 1003 65534 134 Apr 15 2002 dictionary.README
|
|
drwxrwxr-x 2 0 1003 4096 May 03 17:00 diffutils
|
|
drwxr-xr-x 2 1003 1003 4096 Apr 11 11:55 dionysus
|
|
drwxrwxr-x 2 0 0 4096 Apr 03 2007 dismal
|
|
-rw-r--r-- 1 1003 65534 492 Apr 03 2007 djgpp.README
|
|
drwxr-xr-x 2 1003 1003 4096 Feb 18 2005 dominion
|
|
drwxrwxr-x 5 0 1003 4096 Dec 10 2008 dotgnu
|
|
-rw-r--r-- 1 1003 65534 96 Feb 09 1999 dumb.README
|
|
drwxrwxr-x 2 0 1003 4096 Jul 10 2009 ed
|
|
drwxrwxr-x 2 0 1003 4096 Apr 08 18:05 edma
|
|
drwxrwxr-x 2 0 1003 4096 Feb 17 00:20 electric
|
|
-rw-r--r-- 1 1003 65534 835 Jan 24 1999 elisp-archive.README
|
|
drwxrwxr-x 3 0 1003 4096 May 08 04:01 emacs
|
|
drwxr-xr-x 2 1003 1003 4096 Sep 16 2008 emms
|
|
drwxrwxr-x 2 0 1003 4096 Jun 01 23:25 enscript
|
|
drwxr-xr-x 2 1003 1003 4096 Jan 26 2008 erc
|
|
drwxr-xr-x 2 1003 1003 4096 Jan 10 2010 fdisk
|
|
drwxr-xr-x 2 1003 1003 4096 Nov 16 2008 ferret
|
|
drwxrwxr-x 2 0 1003 4096 Jun 06 2009 findutils
|
|
drwxrwxr-x 2 0 0 4096 Mar 20 2007 flex
|
|
drwxrwxr-x 2 0 1003 4096 Aug 02 2003 fontutils
|
|
drwxr-xr-x 2 1003 1003 4096 Apr 20 21:05 freedink
|
|
drwxrwxr-x 2 0 1003 4096 Jan 04 2009 freefont
|
|
@||})
|
|
|
|
(define TEXT-FILE @S{
|
|
1. Sometimes diffs between two versions were either too large to be
|
|
worth making, or too difficult. In those cases where a .diff file is
|
|
missing, please just FTP the latest version.
|
|
|
|
2. The .diff file suffix signifies a patch file produced by the GNU
|
|
'diff' program.
|
|
|
|
A diff file like this has all of the changes from one version of a
|
|
program to the next (i.e. gcc-2.6.2-2.6.3.diff will take gcc-2.6.2 and
|
|
produce gcc 2.6.3).
|
|
|
|
You can use the "patch" program to apply the diff to your sources.
|
|
(The "patch" program is available on prep.ai.mit.edu in directory
|
|
/pub/gnu/ if it isn't already installed on your system.)
|
|
|
|
(You might also want to take a look at the diff file, the format is
|
|
pretty obvious and could be educational. :-)
|
|
|
|
Thank You!
|
|
@||})
|
|
|
|
(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:
|
|
230-
|
|
230- This site includes publicly available encryption source code
|
|
230- which, together with object code resulting from the compiling of
|
|
230- publicly available source code, may be exported from the United
|
|
230- States under License Exception "TSU" pursuant to 15 C.F.R. Section
|
|
230- 740.13(e).
|
|
230-
|
|
230-This legal notice applies to cryptographic software only. Please see
|
|
230-the Bureau of Industry and Security (www.bxa.doc.gov) for more
|
|
230-information about current U.S. regulations.
|
|
230 Login successful.
|
|
250-If you have problems downloading and are seeing "Access denied" or
|
|
250-"Permission denied", please make sure that you started your FTP client
|
|
250-in a directory to which you have write permission.
|
|
250-
|
|
250-Please note that all files ending in `.gz' are compressed with `gzip',
|
|
250-not with the unix `compress' program. Get the file below for more
|
|
250-info.
|
|
250-
|
|
250-For a list of mirrors and other ways of getting GNU software, FTP the
|
|
250-file /pub/gnu/GNUinfo/FTP from ftp.gnu.org or one of its mirror sites.
|
|
250-
|
|
250-Programs that are directly in this directory are actually GNU
|
|
250-programs, developed under the auspices of GNU.
|
|
250-
|
|
250-We do, however, distribute some non-GNU programs through our FTP
|
|
250-server, or provide pointers to where they are. We put these
|
|
250-programs/pointers in the subdirectory non-gnu since they are not
|
|
250-developed by the GNU project. They are, of course, part of the GNU
|
|
250-system. See:
|
|
250-http://www.gnu.org/philosophy/categories.html#TheGNUsystem
|
|
250 Directory successfully changed.
|
|
227 Entering Passive Mode (127,0,0,1,@pasv1-port)
|
|
200 Switching to Binary mode.
|
|
150 Here comes the directory listing.
|
|
226 Directory send OK.
|
|
227 Entering Passive Mode (127,0,0,1,@pasv2-port)
|
|
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.
|
|
@||})
|
|
|
|
(define EXPECTED-USER-OUTPUT
|
|
@(lambda xs (regexp-replace* #rx"\n" (apply S xs) "\r\n")){
|
|
USER anonymous
|
|
CWD gnu
|
|
PASV
|
|
TYPE I
|
|
LIST
|
|
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
|
|
@||})
|