1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes.singleton combinators
4 continuations io io.encodings.binary io.encodings.utf8
5 io.files io.pathnames io.sockets kernel io.streams.duplex math
6 math.parser sequences splitting namespaces strings fry ftp
7 ftp.client.listing-parser urls ;
10 : (ftp-response-code) ( str -- n )
11 3 head string>number ;
13 : ftp-response-code ( string -- n/f )
14 dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
16 : read-response-loop ( ftp-response -- ftp-response )
18 [ add-response-line ] [ ftp-response-code ] bi
19 over n>> = [ read-response-loop ] unless ;
21 : read-response ( -- ftp-response )
23 [ (ftp-response-code) >>n ]
25 [ fourth CHAR: - = ] tri
26 [ read-response-loop ] when ;
28 ERROR: ftp-error got expected ;
30 : ftp-assert ( ftp-response n -- )
31 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
33 : ftp-command ( string -- ftp-response )
34 ftp-send read-response ;
36 : ftp-user ( url -- ftp-response )
37 username>> "USER " prepend ftp-command ;
39 : ftp-password ( url -- ftp-response )
40 password>> "PASS " prepend ftp-command ;
42 : ftp-cwd ( directory -- ftp-response )
43 "CWD " prepend ftp-command ;
45 : ftp-retr ( filename -- ftp-response )
46 "RETR " prepend ftp-command ;
48 : ftp-set-binary ( -- ftp-response ) "TYPE I" ftp-command ;
50 : ftp-pwd ( -- ftp-response ) "PWD" ftp-command ;
53 "LIST" ftp-command 150 ftp-assert ;
55 : ftp-quit ( -- ftp-response ) "QUIT" ftp-command ;
57 : ftp-epsv ( -- ftp-response )
58 "EPSV" ftp-command dup 229 ftp-assert ;
60 : parse-epsv ( ftp-response -- port )
61 strings>> first "|" split 2 tail* first string>number ;
63 : open-passive-client ( url protocol -- stream )
64 [ host>> ftp-epsv parse-epsv <inet> ] dip <client> drop ;
66 : list ( url -- ftp-response )
67 utf8 open-passive-client
70 <ftp-response> swap >>strings
71 read-response 226 ftp-assert
74 : (ftp-get) ( url path -- )
75 [ binary open-passive-client ] dip
76 [ ftp-retr 150 ftp-assert drop ]
77 [ binary <file-writer> stream-copy ] 2bi
78 read-response 226 ftp-assert ;
80 : ftp-login ( url -- )
81 read-response 220 ftp-assert
82 [ ftp-user 331 ftp-assert ]
83 [ ftp-password 230 ftp-assert ] bi
84 ftp-set-binary 200 ftp-assert ;
86 : ftp-connect ( url -- stream )
87 [ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
89 : with-ftp-client ( url quot -- )
90 [ [ ftp-connect ] keep ] dip
91 '[ _ [ ftp-login ] _ bi ftp-quit drop ] with-stream ; inline
93 : ensure-login ( url -- url )
95 "anonymous" >>username
96 "ftp-client" >>password
99 : >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
104 [ nip parent-directory ftp-cwd drop ]
105 [ file-name (ftp-get) ] 2bi