1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors calendar calendar.format classes combinators
4 combinators.short-circuit concurrency.promises continuations
5 destructors ftp io io.directories io.encodings
6 io.encodings.8-bit.latin1 io.encodings.binary io.encodings.utf8
7 io.files io.files.info io.files.types io.pathnames
8 io.servers.connection io.sockets io.streams.string io.timeouts
9 kernel logging math math.bitwise math.parser namespaces
10 sequences simple-tokenizer splitting strings threads
11 tools.files unicode.case ;
17 TUPLE: ftp-server < threaded-server { serving-directory string } ;
19 TUPLE: ftp-client user password extra-connection ;
21 TUPLE: ftp-command raw tokenized ;
22 : <ftp-command> ( str -- obj )
23 dup \ <ftp-command> DEBUG log-message
26 swap tokenize >>tokenized ;
29 : <ftp-get> ( path -- obj )
34 : <ftp-put> ( path -- obj )
39 C: <ftp-list> ftp-list
41 TUPLE: ftp-disconnect ;
42 C: <ftp-disconnect> ftp-disconnect
44 : (send-response) ( n string separator -- )
45 [ number>string write ] 2dip write ftp-send ;
47 : send-response ( ftp-response -- )
48 [ n>> ] [ strings>> ] bi
49 [ but-last-slice [ "-" (send-response) ] with each ]
50 [ first " " (send-response) ] 2bi ;
52 : make-path-relative? ( path -- ? )
55 [ drop server get serving-directory>> ]
58 : fixup-relative-path ( string -- string' )
59 dup make-path-relative? [
60 [ server get serving-directory>> ] dip append-relative-path
63 : server-response ( string n -- )
64 2dup number>string swap ":" glue \ server-response DEBUG log-message
67 swap add-response-line
70 : serving? ( path -- ? )
71 resolve-symlinks server get serving-directory>> head? ;
73 : can-serve-directory? ( path -- ? )
74 { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
76 : can-serve-file? ( path -- ? )
79 [ file-info type>> +regular-file+ = ]
83 : ftp-error ( string -- ) 500 server-response ;
84 : ftp-unimplemented ( string -- ) 502 server-response ;
87 "Welcome to " host-name append 220 server-response ;
89 : anonymous-only ( -- )
90 "This FTP server is anonymous only." 530 server-response ;
92 : handle-QUIT ( obj -- )
93 drop "Goodbye." 221 server-response ;
95 : handle-USER ( ftp-command -- )
97 tokenized>> second client get user<<
98 "Please specify the password." 331 server-response
100 2drop "bad USER" ftp-error
103 : handle-PASS ( ftp-command -- )
105 tokenized>> second client get password<<
106 "Login successful" 230 server-response
108 2drop "PASS error" ftp-error
111 ERROR: type-error type ;
113 : parse-type ( string -- string' )
115 { "IMAGE" [ "Binary" ] }
120 : handle-TYPE ( obj -- )
122 tokenized>> second parse-type
123 "Switching to " " mode" surround 200 server-response
125 2drop "TYPE is binary only" ftp-error
128 : random-local-server ( -- server )
129 remote-address get class new binary <server> ;
131 : port>bytes ( port -- hi lo )
132 [ -8 shift ] keep [ 8 bits ] bi@ ;
134 : display-directory ( -- string )
135 current-directory get server get serving-directory>> swap ?head drop
138 : handle-PWD ( obj -- )
140 display-directory get "\"" dup surround 257 server-response ;
142 : handle-SYST ( obj -- )
144 "UNIX Type: L8" 215 server-response ;
146 : start-directory ( -- )
147 "Here comes the directory listing." 150 server-response ;
149 : transfer-outgoing-file ( path -- )
150 [ "Opening BINARY mode data connection for " ] dip
152 file-info size>> number>string
153 "(" " bytes)." surround
154 ] bi " " glue append 150 server-response ;
156 : transfer-incoming-file ( path -- )
157 "Opening BINARY mode data connection for " prepend
158 150 server-response ;
160 : finish-file-transfer ( -- )
161 "File send OK." 226 server-response ;
163 GENERIC: handle-passive-command ( stream obj -- )
165 : passive-loop ( server -- )
169 30 seconds over set-timeout
171 client get extra-connection>>
172 30 seconds ?promise-timeout
173 handle-passive-command
175 [ client get f >>extra-connection drop ]
179 : finish-directory ( -- )
180 "Directory send OK." 226 server-response ;
182 M: ftp-list handle-passive-command ( stream obj -- )
186 current-directory get directory.
187 ] with-string-writer string-lines
188 harvest [ ftp-send ] each
189 ] with-output-stream finish-directory ;
191 M: ftp-get handle-passive-command ( stream obj -- )
194 [ transfer-outgoing-file ]
195 [ binary <file-reader> swap stream-copy ] bi
198 3drop "File transfer failed" ftp-error
201 M: ftp-put handle-passive-command ( stream obj -- )
204 [ transfer-incoming-file ]
205 [ binary <file-writer> stream-copy ] bi
208 3drop "File transfer failed" ftp-error
211 M: ftp-disconnect handle-passive-command ( stream obj -- )
214 : fulfill-client ( obj -- )
215 client get extra-connection>> [
219 "Establish an active or passive connection first" ftp-error
222 : handle-STOR ( obj -- )
224 dup can-serve-file? [
225 <ftp-put> fulfill-client
228 <ftp-disconnect> fulfill-client
231 : handle-LIST ( obj -- )
232 drop current-directory get
233 can-serve-directory? [
234 <ftp-list> fulfill-client
236 <ftp-disconnect> fulfill-client
239 : not-a-plain-file ( path -- )
240 ": not a plain file." append ftp-error ;
242 : handle-RETR ( obj -- )
245 dup can-serve-file? [
246 <ftp-get> fulfill-client
249 <ftp-disconnect> fulfill-client
252 : handle-SIZE ( obj -- )
254 dup can-serve-file? [
255 file-info size>> number>string 213 server-response
260 : expect-connection ( -- port )
261 <promise> client get extra-connection<<
263 [ [ passive-loop ] curry in-thread ]
264 [ addr>> port>> ] bi ;
266 : handle-PASV ( obj -- )
268 expect-connection port>bytes [ number>string ] bi@ "," glue
269 "Entering Passive Mode (127,0,0,1," ")" surround
270 221 server-response ;
272 : handle-EPSV ( obj -- )
274 client get f >>extra-connection drop
275 expect-connection number>string
276 "Entering Extended Passive Mode (|||" "|)" surround
277 229 server-response ;
279 : handle-MDTM ( obj -- )
280 tokenized>> 1 swap ?nth [
282 dup file-info dup directory? [
283 drop not-a-plain-file
286 modified>> timestamp>mdtm
293 ERROR: not-a-directory ;
294 ERROR: no-directory-permissions ;
296 : directory-change-success ( -- )
297 "Directory successully changed." 250 server-response ;
299 : directory-change-failed ( -- )
300 "Failed to change directory." 553 server-response ;
302 : handle-CWD ( obj -- )
303 tokenized>> 1 swap ?nth [
305 dup can-serve-directory? [
306 set-current-directory
307 directory-change-success
310 directory-change-failed
313 directory-change-success
316 : unrecognized-command ( obj -- )
317 raw>> "Unrecognized command: " prepend ftp-error ;
319 : client-loop-dispatch ( str/f -- ? )
320 dup tokenized>> first >upper {
321 { "QUIT" [ handle-QUIT f ] }
322 { "USER" [ handle-USER t ] }
323 { "PASS" [ handle-PASS t ] }
324 { "SYST" [ handle-SYST t ] }
325 { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] }
326 { "PWD" [ handle-PWD t ] }
327 { "TYPE" [ handle-TYPE t ] }
328 { "CWD" [ handle-CWD t ] }
329 { "PASV" [ handle-PASV t ] }
330 { "EPSV" [ handle-EPSV t ] }
331 { "LIST" [ handle-LIST t ] }
332 { "STOR" [ handle-STOR t ] }
333 { "RETR" [ handle-RETR t ] }
334 { "SIZE" [ handle-SIZE t ] }
335 { "MDTM" [ handle-MDTM t ] }
336 [ drop unrecognized-command t ]
339 : read-command ( -- ftp-command/f )
340 readln [ f ] [ <ftp-command> ] if-empty ;
342 : handle-client-loop ( -- )
345 [ handle-client-loop ] when
348 : serve-directory ( server -- )
349 serving-directory>> [
354 M: ftp-server handle-client* ( server -- )
356 "New client" \ handle-client* DEBUG log-message
357 ftp-client new client set
358 [ server set ] [ serve-directory ] bi
361 : <ftp-server> ( directory port -- server )
362 latin1 ftp-server new-threaded-server
364 swap resolve-symlinks >>serving-directory
366 5 minutes >>timeout ;
368 : ftpd ( directory port -- server )
369 <ftp-server> start-server ;
371 ! sudo tcpdump -i en1 -A -s 10000 tcp port 21
372 ! [2010-09-04T22:07:58-05:00] DEBUG server-response: 500:Unrecognized command: EPRT |2|0:0:0:0:0:0:0:1|59359|