diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 608f14544b..3539b2d5c2 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -19,21 +19,32 @@ TUPLE: ftp-response n strings ; "anonymous" >>user "lol@test.com" >>password ; -: read-epsv ( stream -- port ) - dup stream-readln dup print - "|" split 2 tail* first string>number ; +: add-response-line ( ftp-response string -- ftp-response ) + over strings>> push ; -: read-until-command ( stream ftp-response -- n ) +: (ftp-response-code) ( str -- n ) + 3 head string>number ; + +: ftp-response-code ( string -- n/f ) + dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ; + +: last-code ( ftp-response -- n ) + strings>> peek (ftp-response-code) ; + +: read-response-until ( stream ftp-response n -- ftp-response ) + >r over stream-readln + [ add-response-line ] [ ftp-response-code ] bi + r> tuck = [ drop nip ] [ read-response-until ] if ; + +: read-response ( stream -- ftp-response ) + over stream-readln - " " split1 drop string>number dup number? [ - nip - ] [ - drop read-until-command - ] if ; + [ add-response-line ] [ fourth CHAR: - = ] bi + [ dup last-code read-response-until ] + [ nip ] if dup last-code >>n ; : ftp-read ( ftp-client -- ftp-response ) - stream>> [ read-until-command ] keep - dup strings>> peek " " split1 ; + stream>> read-response ; : ftp-send ( str ftp-client -- ) stream>> @@ -48,24 +59,29 @@ TUPLE: ftp-response n strings ; : ftp-user ( ftp-client -- n ) dup user>> "USER " prepend ftp-command ; : ftp-password ( ftp-client -- n ) dup password>> "PASS " prepend ftp-command ; : ftp-set-binary ( ftp-client -- n ) "TYPE I" ftp-command ; -: ftp-set-ascii ( ftp-client -- n ) "TYPE A" ftp-command ; +! : ftp-set-ascii ( ftp-client -- n ) "TYPE A" ftp-command ; : ftp-system ( ftp-client -- n ) "SYST" ftp-command ; : ftp-features ( ftp-client -- n ) "FEAT" ftp-command ; : ftp-pwd ( ftp-client -- n ) "PWD" ftp-command ; : ftp-list ( ftp-client -- n ) "LIST" ftp-command ; : ftp-quit ( ftp-client -- n ) "QUIT" ftp-command ; -: ftp-epsv ( ftp-client -- n str ) "EPSV" ftp-command ; : ftp-cwd ( ftp-client directory -- n ) "CWD " prepend ftp-command ; : ftp-retr ( ftp-client filename -- n ) "RETR " prepend ftp-command ; +: parse-epsv ( ftp-response -- port ) + strings>> first + "|" split 2 tail* first string>number ; + +: ftp-epsv ( ftp-client -- n ) "EPSV" ftp-command ; + M: ftp-client dispose ( ftp-client -- ) - [ "QUIT" ftp-command ] [ stream>> dispose ] bi ; + [ "QUIT" ftp-command drop ] [ stream>> dispose ] bi ; ERROR: ftp-error got expected ; -: ftp-assert ( m n -- ) - 2dup = [ 2drop ] [ ftp-error ] if ; +: ftp-assert ( ftp-response n -- ) + 2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ; -: ftp-connect ( ftp-client -- stream ) +: ftp-connect ( ftp-client -- ) dup [ host>> ] [ port>> ] bi ascii >>stream drop ; @@ -79,29 +95,17 @@ ERROR: ftp-error got expected ; [ ftp-set-binary 200 ftp-assert ] } cleave ; -: list ( stream -- ) - dup ftp-epsv - dup read-epsv - ! host get swap binary - over ftp-list - over read-until-command drop - contents write - read-until-command drop ; +: list ( ftp-client -- ftp-response ) + dup ftp-epsv dup 229 ftp-assert + >r dup host>> r> parse-epsv ascii + over ftp-list 150 ftp-assert + lines swap >>strings + >r ftp-read 226 ftp-assert r> ; -: ftp-get ( ftp-client filename -- ) - over ftp-epsv 229 ftp-assert - - ; - -! : ftp-get ( path stream -- ) - ! dup ftp-epsv - ! dup read-epsv - ! ! host get swap binary - ! >r [ ftp-retr ] 2keep dup read-until-command drop r> - ! rot binary stream-copy - ! read-until-command drop ; - - - -: ftp-interact ( stream -- ) - readln over ftp-send read-until-command drop ; +: ftp-get ( ftp-client filename -- ftp-response ) + over ftp-epsv dup 229 ftp-assert + pick host>> swap parse-epsv binary + swap tuck + [ dupd ftp-retr 150 ftp-assert ] + [ binary stream-copy ] 2bi* + ftp-read dup 226 ftp-assert ;