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.sockets kernel io.streams.duplex math
6 math.parser sequences splitting namespaces strings fry ftp ;
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 : ftp-command ( string -- ftp-response )
28 ftp-send read-response ;
30 : ftp-user ( ftp-client -- ftp-response )
31 user>> "USER " prepend ftp-command ;
33 : ftp-password ( ftp-client -- ftp-response )
34 password>> "PASS " prepend ftp-command ;
36 : ftp-set-binary ( -- ftp-response )
37 "TYPE I" ftp-command ;
39 : ftp-pwd ( -- ftp-response )
42 : ftp-list ( -- ftp-response )
45 : ftp-quit ( -- ftp-response )
48 : ftp-cwd ( directory -- ftp-response )
49 "CWD " prepend ftp-command ;
51 : ftp-retr ( filename -- ftp-response )
52 "RETR " prepend ftp-command ;
54 : parse-epsv ( ftp-response -- port )
56 "|" split 2 tail* first string>number ;
59 type permissions links owner group size month day time year
62 : <remote-file> ( -- remote-file ) remote-file new ;
64 : parse-permissions ( remote-file str -- remote-file )
65 [ first ch>type >>type ] [ rest >>permissions ] bi ;
67 : parse-list-11 ( lines -- seq )
71 [ 0 swap nth parse-permissions ]
72 [ 1 swap nth string>number >>links ]
73 [ 2 swap nth >>owner ]
74 [ 3 swap nth >>group ]
75 [ 4 swap nth string>number >>size ]
76 [ 5 swap nth >>month ]
80 [ 10 swap nth >>target ]
84 : parse-list-8 ( lines -- seq )
87 [ 0 swap nth parse-permissions ]
88 [ 1 swap nth string>number >>links ]
89 [ 2 swap nth >>owner ]
91 [ 4 swap nth >>month ]
98 : parse-list-3 ( lines -- seq )
101 [ 0 swap nth parse-permissions ]
102 [ 1 swap nth string>number >>links ]
103 [ 2 swap nth >>name ]
107 : parse-list ( ftp-response -- ftp-response )
109 [ " " split harvest ] map
111 { 11 [ parse-list-11 ] }
112 { 9 [ parse-list-11 ] }
113 { 8 [ parse-list-8 ] }
114 { 3 [ parse-list-3 ] }
118 : ftp-epsv ( -- ftp-response )
121 ERROR: ftp-error got expected ;
122 : ftp-assert ( ftp-response n -- )
123 2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
125 : ftp-login ( ftp-client -- )
126 read-response 220 ftp-assert
127 [ ftp-user 331 ftp-assert ]
128 [ ftp-password 230 ftp-assert ] bi
129 ftp-set-binary 200 ftp-assert ;
131 : open-remote-port ( -- port )
133 [ 229 ftp-assert ] [ parse-epsv ] bi ;
135 : list ( ftp-client -- ftp-response )
136 host>> open-remote-port <inet> utf8 <client> drop
137 ftp-list 150 ftp-assert
139 <ftp-response> swap >>strings
140 read-response 226 ftp-assert
143 : ftp-get ( filename ftp-client -- ftp-response )
144 host>> open-remote-port <inet> binary <client> drop
146 [ ftp-retr 150 ftp-assert drop ]
147 [ binary <file-writer> stream-copy ] 2bi
148 read-response dup 226 ftp-assert ;
150 : ftp-connect ( ftp-client -- stream )
151 [ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
153 GENERIC: ftp-download ( path obj -- )
155 : with-ftp-client ( ftp-client quot -- )
157 , [ ftp-login ] [ @ ] bi
159 ] >r ftp-connect r> with-stream ; inline
161 M: ftp-client ftp-download ( path ftp-client -- )
163 [ drop parent-directory ftp-cwd drop ]
164 [ >r file-name r> ftp-get drop ] 2bi
167 M: string ftp-download ( path string -- )
168 <ftp-client> ftp-download ;