add a couple unit tests to ftp
parent
966627a1e2
commit
30e639ae39
|
@ -93,7 +93,7 @@ ERROR: ftp-error got expected ;
|
||||||
: ensure-login ( url -- url )
|
: ensure-login ( url -- url )
|
||||||
dup username>> [
|
dup username>> [
|
||||||
"anonymous" >>username
|
"anonymous" >>username
|
||||||
"ftp-client" >>password
|
"ftp-client@factorcode.org" >>password
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
|
: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
|
||||||
|
|
|
@ -16,7 +16,3 @@ TUPLE: ftp-response n strings parsed ;
|
||||||
over strings>> push ;
|
over strings>> push ;
|
||||||
|
|
||||||
: ftp-send ( string -- ) write "\r\n" write flush ;
|
: 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? ;
|
normalize-path server get serving-directory>> head? ;
|
||||||
|
|
||||||
: can-serve-directory? ( path -- ? )
|
: can-serve-directory? ( path -- ? )
|
||||||
canonicalize-path
|
|
||||||
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
|
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
|
||||||
|
|
||||||
: can-serve-file? ( path -- ? )
|
: can-serve-file? ( path -- ? )
|
||||||
canonicalize-path
|
|
||||||
{
|
{
|
||||||
[ exists? ]
|
[ exists? ]
|
||||||
[ file-info type>> +regular-file+ = ]
|
[ file-info type>> +regular-file+ = ]
|
||||||
|
@ -351,7 +349,7 @@ M: ftp-server handle-client* ( server -- )
|
||||||
: <ftp-server> ( directory port -- server )
|
: <ftp-server> ( directory port -- server )
|
||||||
ftp-server new-threaded-server
|
ftp-server new-threaded-server
|
||||||
swap >>insecure
|
swap >>insecure
|
||||||
swap >>serving-directory
|
swap canonicalize-path >>serving-directory
|
||||||
"ftp.server" >>name
|
"ftp.server" >>name
|
||||||
5 minutes >>timeout
|
5 minutes >>timeout
|
||||||
latin1 >>encoding ;
|
latin1 >>encoding ;
|
||||||
|
|
Loading…
Reference in New Issue