1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs byte-arrays calendar classes
4 combinators combinators.short-circuit concurrency.promises
5 continuations destructors ftp io io.backend io.directories
6 io.encodings io.encodings.8-bit io.encodings.binary
7 tools.files io.encodings.utf8 io.files io.files.info
8 io.pathnames io.launcher.unix.parser io.servers.connection
9 io.sockets io.streams.duplex io.streams.string io.timeouts
10 kernel make math math.bitwise math.parser namespaces sequences
11 splitting threads unicode.case logging calendar.format
12 strings io.files.links io.files.types ;
18 TUPLE: ftp-server < threaded-server { serving-directory string } ;
20 TUPLE: ftp-client user password extra-connection ;
22 TUPLE: ftp-command raw tokenized ;
23 : <ftp-command> ( str -- obj )
24 dup \ <ftp-command> DEBUG log-message
27 swap tokenize-command >>tokenized ;
30 : <ftp-get> ( path -- obj )
35 : <ftp-put> ( path -- obj )
40 C: <ftp-list> ftp-list
42 TUPLE: ftp-disconnect ;
43 C: <ftp-disconnect> ftp-disconnect
45 : (send-response) ( n string separator -- )
46 [ number>string write ] 2dip write ftp-send ;
48 : send-response ( ftp-response -- )
49 [ n>> ] [ strings>> ] bi
50 [ but-last-slice [ "-" (send-response) ] with each ]
51 [ first " " (send-response) ] 2bi ;
53 : server-response ( string n -- )
54 2dup number>string swap ":" glue \ server-response DEBUG log-message
57 swap add-response-line
60 : serving? ( path -- ? )
61 canonicalize-path server get serving-directory>> head? ;
63 : can-serve-directory? ( path -- ? )
64 { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
66 : can-serve-file? ( path -- ? )
69 [ file-info type>> +regular-file+ = ]
73 : ftp-error ( string -- ) 500 server-response ;
74 : ftp-unimplemented ( string -- ) 502 server-response ;
77 "Welcome to " host-name append 220 server-response ;
79 : anonymous-only ( -- )
80 "This FTP server is anonymous only." 530 server-response ;
82 : handle-QUIT ( obj -- )
83 drop "Goodbye." 221 server-response ;
85 : handle-USER ( ftp-command -- )
87 tokenized>> second client get (>>user)
88 "Please specify the password." 331 server-response
90 2drop "bad USER" ftp-error
93 : handle-PASS ( ftp-command -- )
95 tokenized>> second client get (>>password)
96 "Login successful" 230 server-response
98 2drop "PASS error" ftp-error
101 ERROR: type-error type ;
103 : parse-type ( string -- string' )
105 { "IMAGE" [ "Binary" ] }
110 : handle-TYPE ( obj -- )
112 tokenized>> second parse-type
113 "Switching to " " mode" surround 200 server-response
115 2drop "TYPE is binary only" ftp-error
118 : random-local-server ( -- server )
119 remote-address get class new 0 >>port binary <server> ;
121 : port>bytes ( port -- hi lo )
122 [ -8 shift ] keep [ 8 bits ] bi@ ;
124 : handle-PWD ( obj -- )
126 current-directory get "\"" dup surround 257 server-response ;
128 : handle-SYST ( obj -- )
130 "UNIX Type: L8" 215 server-response ;
132 : start-directory ( -- )
133 "Here comes the directory listing." 150 server-response ;
135 : transfer-outgoing-file ( path -- )
136 [ "Opening BINARY mode data connection for " ] dip
138 file-info size>> number>string
139 "(" " bytes)." surround
140 ] bi " " glue append 150 server-response ;
142 : transfer-incoming-file ( path -- )
143 "Opening BINARY mode data connection for " prepend
144 150 server-response ;
146 : finish-file-transfer ( -- )
147 "File send OK." 226 server-response ;
149 GENERIC: handle-passive-command ( stream obj -- )
151 : passive-loop ( server -- )
155 30 seconds over set-timeout
157 client get extra-connection>>
158 30 seconds ?promise-timeout
159 handle-passive-command
161 [ client get f >>extra-connection drop ]
165 : finish-directory ( -- )
166 "Directory send OK." 226 server-response ;
168 M: ftp-list handle-passive-command ( stream obj -- )
172 [ current-directory get directory. ] with-string-writer string-lines
173 harvest [ ftp-send ] each
174 ] with-output-stream finish-directory ;
176 M: ftp-get handle-passive-command ( stream obj -- )
179 [ transfer-outgoing-file ]
180 [ binary <file-reader> swap stream-copy ] bi
183 3drop "File transfer failed" ftp-error
186 M: ftp-put handle-passive-command ( stream obj -- )
189 [ transfer-incoming-file ]
190 [ binary <file-writer> stream-copy ] bi
193 3drop "File transfer failed" ftp-error
196 M: ftp-disconnect handle-passive-command ( stream obj -- )
199 : fulfill-client ( obj -- )
200 client get extra-connection>> [
204 "Establish an active or passive connection first" ftp-error
207 : handle-STOR ( obj -- )
209 dup can-serve-file? [
210 <ftp-put> fulfill-client
213 <ftp-disconnect> fulfill-client
216 : handle-LIST ( obj -- )
217 drop current-directory get
218 can-serve-directory? [
219 <ftp-list> fulfill-client
221 <ftp-disconnect> fulfill-client
224 : not-a-plain-file ( path -- )
225 ": not a plain file." append ftp-error ;
227 : handle-RETR ( obj -- )
229 dup can-serve-file? [
230 <ftp-get> fulfill-client
233 <ftp-disconnect> fulfill-client
236 : handle-SIZE ( obj -- )
238 dup can-serve-file? [
239 file-info size>> number>string 213 server-response
244 : expect-connection ( -- port )
245 <promise> client get (>>extra-connection)
247 [ [ passive-loop ] curry in-thread ]
248 [ addr>> port>> ] bi ;
250 : handle-PASV ( obj -- )
252 expect-connection port>bytes [ number>string ] bi@ "," glue
253 "Entering Passive Mode (127,0,0,1," ")" surround
254 221 server-response ;
256 : handle-EPSV ( obj -- )
258 client get f >>extra-connection drop
259 expect-connection number>string
260 "Entering Extended Passive Mode (|||" "|)" surround
261 229 server-response ;
263 : handle-MDTM ( obj -- )
264 tokenized>> 1 swap ?nth [
265 dup file-info dup directory? [
266 drop not-a-plain-file
269 modified>> timestamp>mdtm
276 ERROR: not-a-directory ;
277 ERROR: no-directory-permissions ;
279 : directory-change-success ( -- )
280 "Directory successully changed." 250 server-response ;
282 : directory-change-failed ( -- )
283 "Failed to change directory." 553 server-response ;
285 : handle-CWD ( obj -- )
286 tokenized>> 1 swap ?nth [
287 dup can-serve-directory? [
288 set-current-directory
289 directory-change-success
292 directory-change-failed
295 directory-change-success
298 : unrecognized-command ( obj -- )
299 raw>> "Unrecognized command: " prepend ftp-error ;
301 : client-loop-dispatch ( str/f -- ? )
302 dup tokenized>> first >upper {
303 { "QUIT" [ handle-QUIT f ] }
304 { "USER" [ handle-USER t ] }
305 { "PASS" [ handle-PASS t ] }
306 { "SYST" [ handle-SYST t ] }
307 { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] }
308 { "PWD" [ handle-PWD t ] }
309 { "TYPE" [ handle-TYPE t ] }
310 { "CWD" [ handle-CWD t ] }
311 { "PASV" [ handle-PASV t ] }
312 { "EPSV" [ handle-EPSV t ] }
313 { "LIST" [ handle-LIST t ] }
314 { "STOR" [ handle-STOR t ] }
315 { "RETR" [ handle-RETR t ] }
316 { "SIZE" [ handle-SIZE t ] }
317 { "MDTM" [ handle-MDTM t ] }
318 [ drop unrecognized-command t ]
321 : read-command ( -- ftp-command/f )
322 readln [ f ] [ <ftp-command> ] if-empty ;
324 : handle-client-loop ( -- )
327 [ handle-client-loop ] when
330 : serve-directory ( server -- )
331 serving-directory>> [
336 M: ftp-server handle-client* ( server -- )
338 "New client" \ handle-client* DEBUG log-message
339 ftp-client new client set
340 [ server set ] [ serve-directory ] bi
343 : <ftp-server> ( directory port -- server )
344 latin1 ftp-server new-threaded-server
346 swap canonicalize-path >>serving-directory
348 5 minutes >>timeout ;
350 : ftpd ( directory port -- )
351 <ftp-server> start-server ;
353 : ftpd-main ( path -- ) 2100 ftpd ;
357 ! sudo tcpdump -i en1 -A -s 10000 tcp port 21