1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: combinators.short-circuit accessors combinators io
4 io.encodings.8-bit io.encodings io.encodings.binary
5 io.encodings.utf8 io.files io.sockets kernel math.parser
6 namespaces make sequences ftp io.unix.launcher.parser
7 unicode.case splitting assocs classes io.servers.connection
8 destructors calendar io.timeouts io.streams.duplex threads
9 continuations math concurrency.promises byte-arrays
10 io.backend tools.hexdump tools.files io.streams.string ;
13 TUPLE: ftp-client url mode state command-promise user password ;
15 : <ftp-client> ( url -- ftp-client )
21 : ftp-server-directory ( -- str )
22 \ ftp-server-directory get-global "resource:temp" or
25 TUPLE: ftp-command raw tokenized ;
27 : <ftp-command> ( -- obj )
32 : <ftp-get> ( path -- obj )
38 : <ftp-put> ( path -- obj )
44 C: <ftp-list> ftp-list
46 : read-command ( -- ftp-command )
48 [ >>raw ] [ tokenize-command >>tokenized ] bi ;
50 : (send-response) ( n string separator -- )
51 rot number>string write write ftp-send ;
53 : send-response ( ftp-response -- )
54 [ n>> ] [ strings>> ] bi
55 [ but-last-slice [ "-" (send-response) ] with each ]
56 [ first " " (send-response) ] 2bi ;
58 : server-response ( n string -- )
60 swap add-response-line
64 : ftp-error ( string -- )
65 500 "Unrecognized command: " rot append server-response ;
68 220 "Welcome to " host-name append server-response ;
70 : anonymous-only ( -- )
71 530 "This FTP server is anonymous only." server-response ;
73 : handle-QUIT ( obj -- )
74 drop 221 "Goodbye." server-response ;
76 : handle-USER ( ftp-command -- )
78 tokenized>> second client get (>>user)
79 331 "Please specify the password." server-response
81 2drop "bad USER" ftp-error
84 : handle-PASS ( ftp-command -- )
86 tokenized>> second client get (>>password)
87 230 "Login successful" server-response
89 2drop "PASS error" ftp-error
92 ERROR: type-error type ;
94 : parse-type ( string -- string' )
96 { "IMAGE" [ "Binary" ] }
101 : handle-TYPE ( obj -- )
103 tokenized>> second parse-type
104 200 "Switching to " rot " mode" 3append server-response
106 2drop "TYPE is binary only" ftp-error
109 : random-local-server ( -- server )
110 remote-address get class new 0 >>port binary <server> ;
112 : port>bytes ( port -- hi lo )
113 [ -8 shift ] keep [ HEX: ff bitand ] bi@ ;
115 : handle-PWD ( obj -- )
117 257 current-directory get "\"" "\"" surround server-response ;
119 : handle-SYST ( obj -- )
121 215 "UNIX Type: L8" server-response ;
123 : if-command-promise ( quot -- )
124 [ client get command-promise>> ] dip
125 [ "Establish an active or passive connection first" ftp-error ] if* ;
127 : handle-STOR ( obj -- )
130 [ [ <ftp-put> ] dip fulfill ] if-command-promise
136 ! : handle-EPRT ( obj -- )
137 ! tokenized>> second "|" split harvest ;
139 : start-directory ( -- )
140 150 "Here comes the directory listing." server-response ;
142 : finish-directory ( -- )
143 226 "Directory send OK." server-response ;
145 GENERIC: service-command ( stream obj -- )
147 M: ftp-list service-command ( stream obj -- )
151 [ current-directory get directory. ] with-string-writer string-lines
152 harvest [ ftp-send ] each
156 : transfer-outgoing-file ( path -- )
157 150 "Opening BINARY mode data connection for "
160 " " swap file-info size>> number>string
161 "(" " bytes)." surround append
162 ] bi 3append server-response ;
164 : transfer-incoming-file ( path -- )
165 150 "Opening BINARY mode data connection for " rot append
168 : finish-file-transfer ( -- )
169 226 "File send OK." server-response ;
171 M: ftp-get service-command ( stream obj -- )
174 [ transfer-outgoing-file ]
175 [ binary <file-reader> swap stream-copy ] bi
178 3drop "File transfer failed" ftp-error
181 M: ftp-put service-command ( stream obj -- )
184 [ transfer-incoming-file ]
185 [ binary <file-writer> stream-copy ] bi
188 3drop "File transfer failed" ftp-error
191 : passive-loop ( server -- )
195 30 seconds over set-timeout
197 client get command-promise>>
198 30 seconds ?promise-timeout
201 [ client get f >>command-promise drop ]
205 : handle-LIST ( obj -- )
207 [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
209 : handle-SIZE ( obj -- )
211 tokenized>> second file-info size>>
212 213 swap number>string server-response
215 550 "Could not get file size" server-response
218 : handle-RETR ( obj -- )
219 [ tokenized>> second <ftp-get> swap fulfill ]
220 curry if-command-promise ;
222 : expect-connection ( -- port )
224 client get <promise> >>command-promise drop
225 [ [ passive-loop ] curry in-thread ]
226 [ addr>> port>> ] bi ;
228 : handle-PASV ( obj -- )
229 drop client get passive >>mode drop
232 "Entering Passive Mode (127,0,0,1," %
233 port>bytes [ number>string ] bi@ "," glue %
235 ] "" make 227 swap server-response ;
237 : handle-EPSV ( obj -- )
239 client get command-promise>> [
240 "You already have a passive stream" ftp-error
242 229 "Entering Extended Passive Mode (|||"
243 expect-connection number>string
244 "|)" 3append server-response
247 ! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
248 ! : handle-LPRT ( obj -- ) tokenized>> "," split ;
250 ERROR: not-a-directory ;
251 ERROR: no-permissions ;
253 : handle-CWD ( obj -- )
255 tokenized>> second dup normalize-path
256 dup ftp-server-directory head? [
260 file-info directory? [
261 set-current-directory
262 250 "Directory successully changed." server-response
268 550 "Failed to change directory." server-response
271 : unrecognized-command ( obj -- ) raw>> ftp-error ;
273 : handle-client-loop ( -- )
275 USE: prettyprint global [ dup . flush ] bind
277 [ tokenize-command >>tokenized ] bi
278 dup tokenized>> first >upper {
279 { "USER" [ handle-USER t ] }
280 { "PASS" [ handle-PASS t ] }
281 { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
282 { "CWD" [ handle-CWD t ] }
287 ! { "REIN" [ drop client get reset-ftp-client t ] }
288 { "QUIT" [ handle-QUIT f ] }
290 ! { "PORT" [ ] } ! TODO
291 { "PASV" [ handle-PASV t ] }
293 { "TYPE" [ handle-TYPE t ] }
298 { "STOR" [ handle-STOR t ] }
300 { "RETR" [ handle-RETR t ] }
301 { "LIST" [ handle-LIST t ] }
302 { "SIZE" [ handle-SIZE t ] }
307 ! { "DELE" [ handle-DELE t ] }
308 ! { "RMD" [ handle-RMD t ] }
309 ! ! { "XRMD" [ handle-XRMD t ] }
310 ! { "MKD" [ handle-MKD t ] }
311 { "PWD" [ handle-PWD t ] }
314 { "SYST" [ handle-SYST t ] }
321 ! { "EPRT" [ handle-EPRT ] }
322 ! { "LPRT" [ handle-LPRT ] }
323 { "EPSV" [ handle-EPSV t ] }
324 ! { "LPSV" [ drop handle-LPSV t ] }
325 [ drop unrecognized-command t ]
326 } case [ handle-client-loop ] when ;
328 TUPLE: ftp-server < threaded-server ;
330 M: ftp-server handle-client* ( server -- )
333 ftp-server-directory [
334 host-name <ftp-client> client set
335 send-banner handle-client-loop
339 : <ftp-server> ( port -- server )
340 ftp-server new-threaded-server
347 <ftp-server> start-server ;
349 : ftpd-main ( -- ) 2100 ftpd ;
353 ! sudo tcpdump -i en1 -A -s 10000 tcp port 21