add a couple unit tests to ftp
parent
966627a1e2
commit
30e639ae39
|
@ -93,7 +93,7 @@ ERROR: ftp-error got expected ;
|
|||
: ensure-login ( url -- url )
|
||||
dup username>> [
|
||||
"anonymous" >>username
|
||||
"ftp-client" >>password
|
||||
"ftp-client@factorcode.org" >>password
|
||||
] unless ;
|
||||
|
||||
: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
|
||||
|
|
|
@ -16,7 +16,3 @@ TUPLE: ftp-response n strings parsed ;
|
|||
over strings>> push ;
|
||||
|
||||
: ftp-send ( string -- ) write "\r\n" write flush ;
|
||||
|
||||
CONSTANT: ftp-ipv4 1
|
||||
|
||||
CONSTANT: ftp-ipv6 2
|
||||
|
|
|
@ -0,0 +1,50 @@
|
|||
USING: calendar ftp.server io.encodings.ascii io.files
|
||||
io.files.unique namespaces threads tools.test kernel
|
||||
io.servers.connection ftp.client accessors urls
|
||||
io.pathnames io.directories sequences fry ;
|
||||
IN: ftp.server.tests
|
||||
|
||||
: test-file-contents ( -- string )
|
||||
"Files are so boring anymore." ;
|
||||
|
||||
: create-test-file ( -- path )
|
||||
test-file-contents
|
||||
"ftp.server" "test" make-unique-file
|
||||
[ ascii set-file-contents ] keep canonicalize-path ;
|
||||
|
||||
: test-ftp-server ( quot -- )
|
||||
'[
|
||||
current-temporary-directory get 0
|
||||
<ftp-server>
|
||||
[ start-server* ]
|
||||
[
|
||||
sockets>> first addr>> port>>
|
||||
<url>
|
||||
swap >>port
|
||||
"ftp" >>protocol
|
||||
"localhost" >>host
|
||||
create-test-file >>path
|
||||
_ call
|
||||
]
|
||||
[ stop-server ] tri
|
||||
] with-unique-directory drop ; inline
|
||||
|
||||
[ t ]
|
||||
[
|
||||
|
||||
[
|
||||
unique-directory [
|
||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||
] with-directory
|
||||
] test-ftp-server test-file-contents =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
||||
[
|
||||
"/" >>path
|
||||
unique-directory [
|
||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||
] with-directory
|
||||
] test-ftp-server test-file-contents =
|
||||
] must-fail
|
|
@ -61,11 +61,9 @@ C: <ftp-disconnect> ftp-disconnect
|
|||
normalize-path server get serving-directory>> head? ;
|
||||
|
||||
: can-serve-directory? ( path -- ? )
|
||||
canonicalize-path
|
||||
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
|
||||
|
||||
: can-serve-file? ( path -- ? )
|
||||
canonicalize-path
|
||||
{
|
||||
[ exists? ]
|
||||
[ file-info type>> +regular-file+ = ]
|
||||
|
@ -351,7 +349,7 @@ M: ftp-server handle-client* ( server -- )
|
|||
: <ftp-server> ( directory port -- server )
|
||||
ftp-server new-threaded-server
|
||||
swap >>insecure
|
||||
swap >>serving-directory
|
||||
swap canonicalize-path >>serving-directory
|
||||
"ftp.server" >>name
|
||||
5 minutes >>timeout
|
||||
latin1 >>encoding ;
|
||||
|
|
Loading…
Reference in New Issue