cleanups in ftp before going for the juicy meat

db4
Doug Coleman 2008-11-11 13:06:43 -06:00
parent d575664969
commit b502942e1e
3 changed files with 25 additions and 19 deletions

View File

@ -120,7 +120,7 @@ name target ;
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
: ftp-login ( ftp-client -- )
read-response 220 ftp-assert
@ -156,12 +156,12 @@ GENERIC: ftp-download ( path obj -- )
dupd '[
_ [ ftp-login ] [ @ ] bi
ftp-quit drop
] >r ftp-connect r> with-stream ; inline
] [ ftp-connect ] dip with-stream ; inline
M: ftp-client ftp-download ( path ftp-client -- )
[
[ drop parent-directory ftp-cwd drop ]
[ >r file-name r> ftp-get drop ] 2bi
[ [ file-name ] dip ftp-get drop ] 2bi
] with-ftp-client ;
M: string ftp-download ( path string -- )

View File

@ -36,7 +36,6 @@ TUPLE: ftp-response n strings parsed ;
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
: ch>type ( ch -- type )
{
{ CHAR: d [ +directory+ ] }
@ -54,9 +53,13 @@ TUPLE: ftp-response n strings parsed ;
} case ;
: file-info>string ( file-info name -- string )
>r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
[ size>> number>string 15 CHAR: \s pad-left ] bi r>
3array " " join ;
[
[
[ type>> type>ch 1string ]
[ drop "rwx------" append ] bi
]
[ size>> number>string 15 CHAR: \s pad-left ] bi
] dip 3array " " join ;
: directory-list ( -- seq )
"" directory-files

View File

@ -6,7 +6,8 @@ io.encodings.utf8 io.files io.sockets kernel math.parser
namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays ;
continuations math concurrency.promises byte-arrays sequences.lib
hexdump ;
IN: ftp.server
SYMBOL: client
@ -19,12 +20,14 @@ TUPLE: ftp-command raw tokenized ;
TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj )
ftp-get new swap >>path ;
ftp-get new
swap >>path ;
TUPLE: ftp-put path ;
: <ftp-put> ( path -- obj )
ftp-put new swap >>path ;
ftp-put new
swap >>path ;
TUPLE: ftp-list ;
@ -62,7 +65,7 @@ C: <ftp-list> ftp-list
: handle-USER ( ftp-command -- )
[
tokenized>> second client get swap >>user drop
tokenized>> second client get (>>user)
331 "Please specify the password." server-response
] [
2drop "bad USER" ftp-error
@ -70,7 +73,7 @@ C: <ftp-list> ftp-list
: handle-PASS ( ftp-command -- )
[
tokenized>> second client get swap >>password drop
tokenized>> second client get (>>password)
230 "Login successful" server-response
] [
2drop "PASS error" ftp-error
@ -101,20 +104,20 @@ ERROR: type-error type ;
: handle-PWD ( obj -- )
drop
257 current-directory get "\"" swap "\"" 3append server-response ;
257 current-directory get "\"" "\"" surround server-response ;
: handle-SYST ( obj -- )
drop
215 "UNIX Type: L8" server-response ;
: if-command-promise ( quot -- )
>r client get command-promise>> r>
[ client get command-promise>> ] dip
[ "Establish an active or passive connection first" ftp-error ] if* ;
: handle-STOR ( obj -- )
[
tokenized>> second
[ >r <ftp-put> r> fulfill ] if-command-promise
[ [ <ftp-put> ] dip fulfill ] if-command-promise
] [
2drop
] recover ;
@ -145,7 +148,7 @@ M: ftp-list service-command ( stream obj -- )
rot
[ file-name ] [
" " swap file-info size>> number>string
"(" " bytes)." swapd 3append append
"(" " bytes)." surround append
] bi 3append server-response ;
: transfer-incoming-file ( path -- )
@ -191,7 +194,7 @@ M: ftp-put service-command ( stream obj -- )
: handle-LIST ( obj -- )
drop
[ >r <ftp-list> r> fulfill ] if-command-promise ;
[ [ <ftp-list> ] dip fulfill ] if-command-promise ;
: handle-SIZE ( obj -- )
[
@ -217,7 +220,7 @@ M: ftp-put service-command ( stream obj -- )
expect-connection
[
"Entering Passive Mode (127,0,0,1," %
port>bytes [ number>string ] bi@ "," swap 3append %
port>bytes [ number>string ] bi@ "," splice %
")" %
] "" make 227 swap server-response ;
@ -242,7 +245,7 @@ ERROR: not-a-directory ;
set-current-directory
250 "Directory successully changed." server-response
] [
not-a-directory throw
not-a-directory
] if
] [
2drop