1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors ftp ftp.client.listing-parser io
4 io.encodings.binary io.encodings.utf8 io.files io.pathnames
5 io.sockets io.streams.duplex kernel math.parser sequences
9 : (ftp-response-code) ( str -- n )
10 3 head string>number ;
12 : ftp-response-code ( string -- n/f )
13 dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
15 : read-response-loop ( ftp-response -- ftp-response )
17 [ add-response-line ] [ ftp-response-code ] bi
18 over n>> = [ read-response-loop ] unless ;
20 : read-response ( -- ftp-response )
22 [ (ftp-response-code) >>n ]
24 [ fourth CHAR: - = ] tri
25 [ read-response-loop ] when ;
27 ERROR: ftp-error got expected ;
29 : ftp-assert ( ftp-response n -- )
30 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
32 : ftp-command ( string -- ftp-response )
33 ftp-send read-response ;
35 : ftp-user ( url -- ftp-response )
36 username>> "USER " prepend ftp-command ;
38 : ftp-password ( url -- ftp-response )
39 password>> "PASS " prepend ftp-command ;
41 : ftp-cwd ( directory -- ftp-response )
42 "CWD " prepend ftp-command ;
44 : ftp-retr ( filename -- ftp-response )
45 "RETR " prepend ftp-command ;
47 : ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
49 : ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
52 "LIST" ftp-command 150 ftp-assert ;
54 : ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
56 : ftp-epsv ( -- ftp-response )
57 "EPSV" ftp-command dup 229 ftp-assert ;
59 : parse-epsv ( ftp-response -- port )
60 strings>> first "|" split 2 tail* first string>number ;
62 : open-passive-client ( url protocol -- stream )
63 [ url-addr ftp-epsv parse-epsv with-port ] dip <client> drop ;
65 : list ( url -- ftp-response )
66 utf8 open-passive-client
69 <ftp-response> swap >>strings
70 read-response 226 ftp-assert
73 : (ftp-get) ( url path -- )
74 [ binary open-passive-client ] dip
75 [ ftp-retr 150 ftp-assert drop ]
76 [ binary <file-writer> stream-copy ] 2bi
77 read-response 226 ftp-assert ;
79 : ftp-login ( url -- )
80 read-response 220 ftp-assert
81 [ ftp-user 331 ftp-assert ]
82 [ ftp-password 230 ftp-assert ] bi
83 ftp-set-binary 200 ftp-assert ;
85 : ftp-connect ( url -- stream )
86 url-addr utf8 <client> drop ;
88 : with-ftp-client ( url quot -- )
89 [ [ ftp-connect ] keep ] dip
90 '[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
92 : ensure-login ( url -- url )
94 "anonymous" >>username
95 "ftp-client@factorcode.org" >>password
98 : >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
103 [ nip parent-directory ftp-cwd drop ]
104 [ file-name (ftp-get) ] 2bi