Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 629 lines (566 sloc) 17.965 kB
fccc685 Initial open-source release
MLstate authored
1 -generate server (* -*-erlang-*- *)
2
3 %
4 % Copyright © 2011 MLstate
5 %
6 % This file is part of OPA.
7 %
8 % OPA is free software: you can redistribute it and/or modify it under the
9 % terms of the GNU Affero General Public License, version 3, as published by
10 % the Free Software Foundation.
11 %
12 % OPA is distributed in the hope that it will be useful, but WITHOUT ANY
13 % WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14 % FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
15 % more details.
16 %
17 % You should have received a copy of the GNU Affero General Public License
18 % along with OPA. If not, see <http://www.gnu.org/licenses/>.
19 %
20 -debugvar PROTOCOL_DEBUG
21 -protocol FTP
22
23 % ftpServer:
24 % o Conforms to RFC1123 updated minimal server requirements.
25 %
26
27 % TODO: (-=todo, /=partial, +=done)
28 % o RFC959
29 % + USER <SP> <username> <CRLF>
30 % + PASS <SP> <password> <CRLF>
31 % + ACCT <SP> <account-information> <CRLF>
32 % + CWD <SP> <pathname> <CRLF>
33 % + CDUP <CRLF>
34 % - SMNT <SP> <pathname> <CRLF>
35 % + QUIT <CRLF>
36 % - REIN <CRLF>
37 % + PORT <SP> <host-port> <CRLF>
38 % + PASV <CRLF>
39 % / TYPE <SP> <type-code> <CRLF>
40 % / STRU <SP> <structure-code> <CRLF>
41 % / MODE <SP> <mode-code> <CRLF>
42 % + RETR <SP> <pathname> <CRLF>
43 % + STOR <SP> <pathname> <CRLF>
44 % + STOU <CRLF>
45 % + APPE <SP> <pathname> <CRLF>
46 % + ALLO <SP> <decimal-integer> [<SP> R <SP> <decimal-integer>] <CRLF>
47 % + REST <SP> <marker> <CRLF>
48 % + RNFR <SP> <pathname> <CRLF>
49 % + RNTO <SP> <pathname> <CRLF>
50 % - ABOR <CRLF>
51 % + DELE <SP> <pathname> <CRLF>
52 % + RMD <SP> <pathname> <CRLF>
53 % + MKD <SP> <pathname> <CRLF>
54 % + PWD <CRLF>
55 % + LIST [<SP> <pathname>] <CRLF>
56 % + NLST [<SP> <pathname>] <CRLF>
57 % - SITE <SP> <string> <CRLF>
58 % + SYST <CRLF>
59 % / STAT [<SP> <pathname>] <CRLF>
60 % + HELP [<SP> <string>] <CRLF>
61 % + NOOP <CRLF>
62 % o RFC2389
63 % - FEAT <CRLF>
64 % - OPTS <SP> command-name [ <SP> command-options ] <CRLF>
65 % o RFC3659
66 % / SIZE <SP> <pathname> <CRLF>
67 % / MDTM <SP> <pathname> <CRLF>
68 % - REST
69 % - TVFS
70 % - MLST
71 % - MLSD
72 % o all commands in no login
73 % o records
74 % o stat for files/dirs
75 % o check for RFC1123 errata compliance
76
77 -open Printf
78 -open FtpServerType
79
80 -include "libnet/ftpResponses.proto"
81 -include "libnet/ftpMessages.proto"
82 -type payload = unit
83 -include "libnet/rt_proto.proto"
84
85 -type runtime = {
86 rt_plim : int;
87 rt_dialog_name : string;
88 rt_on_close : Scheduler.t -> unit;
89 rt_proto : rt_proto;
90 }
91
92 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
93 %% General states %%
94 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
95 +on_connection(state : FtpServerType.state):
96 {{ Printf.eprintf "on_connection\n" }}
97 % listen ({{ (Network.make_port_spec (Unix.inet_addr_of_string "127.0.0.1") 12345 Network.Unsecured) }}, listen_port2) ;
98 let hello = {{ get_hello_message state }}
99 send(Dummy hello);
100 wait_for_login(state)
101
102 wait_for_login(state):
103 receive
104 | User str ->
105 if {{ str = "admin" }} then
106 let state = {{ {state with is_admin = true; user = Some str} }}
107 send(ReqPass str);
108 wait_for_pass(state)
109 else
110 let state = {{ {state with is_admin = false; user = Some str} }}
111 send(OkLogin);
112 wait_for_request(state)
113 | Syst ->
114 {{ Printf.eprintf "Syst\n%!" }}
115 send(OkSyst);
116 wait_for_login(state)
117 | Quit ->
118 let str = {{ state.goodbye_message }}
119 send(Bye str);
120 -!-
121 | msg ->
122 {{ Printf.eprintf "Error %s\n%!" (string_of_msg msg) }}
123 send(ErrLogin);
124 wait_for_login(state)
125 after state.timeout ->
126 send(ErrTime);
127 let str = {{ state.goodbye_message }}
128 send(Bye str);
129 -!-
130
131 wait_for_pass(state):
132 receive
133 | Pass str ->
134 if {{ (str = "mlstate") }}
135 then
136 send(OkLogin);
137 let state = {{ {state with is_admin = true} }}
138 let _ = {{ cwd state state.default_folder }}
139 wait_for_request(state)
140 else
141 send(ErrPass);
142 let state = {{ {state with is_admin = false; user = None} }}
143 wait_for_login(state)
144 | _ -> send(ErrSyntax);
145 wait_for_login(state)
146 after state.timeout ->
147 send(ErrTime);
148 wait_for_login(state);
149
150 % process_nlst:
151 % Open a connection to the current data_port_spec in the state and
152 % read the given directory's content. Dump a list of files
153 % down the link turning \n into \r\n if in ASCII mode.
154 %
155 process_nlst(state,str,list_fn):
156 let nlst_ok = {{ list state.folder str list_fn }}
157 let nlst = {{ fst nlst_ok }}
158 if {{ snd nlst_ok }} then
159 if {{ state.passive }}
160 then
161 send(DirList);
162 match {{ !state.pasv_port_conn }} with
163 | Some conn2 ->
164 writeconn(conn2,nlst);
165 {{ Scheduler.remove_connection sched conn2 }}
166 {{ state.pasv_port_conn := None }}
167 send(OkDir);
168 wait_for_request(state)
169 | None ->
170 {{ prerr_endline("process_nlst: no pasv connection") }}
171 send(ErrNoFact);
172 wait_for_request(state)
173 ;
174 else
175 connect({{state.data_port_spec,state.data_secure_mode}},process_nlst_pasv,state,nlst)
176 %let conn2 = connect(state.data_port_spec,Network.Unsecured);
177 %let state = {{ {state with data_conn = Some conn2} }}
178 %send(DirList);
179 %writeconn(conn2,nlst);
180 %send(OkDir);
181 %{{ Scheduler.remove_connection sched conn2 }}
182 %let state = {{ {state with data_conn = None} }}
183 %wait_for_request(state)
184 else
185 send(ErrNoFact);
186 wait_for_request(state)
187 end
188
189 process_nlst_pasv(state,nlst,conn2):
190 send(DirList);
191 writeconn(conn2,nlst);
192 send(OkDir);
193 {{ Scheduler.remove_connection sched conn2 }}
194 let state = {{ {state with data_conn = None} }}
195 wait_for_request(state)
196
197 % output_ascii_file:
198 % Given a connection and a filename, dump the file contents down the link. We
199 % need to take care with the RFC 959 data conventions. Currently, we only do
200 % crlf conversion. The blocksize is set in the state.
201 output_ascii_file(state,str,conn2):
202 match {{ open_folder_read state str }} with
203 | Some fd ->
204 let bin = {{ get_binary_mode state }}
205 send(BinConn bin);
206 output_ascii_file_n(state,conn2,fd)
207 | None ->
208 send(ErrFailOpen);
209 wait_for_request(state)
210
211 output_ascii_file_n(state,conn2,fd):
212 match {{ read_folder state fd state.data_blocksize }} with
213 | Some "" ->
214 {{ close_folder fd }}
215 {{ Scheduler.remove_connection sched conn2 }}
216 let state = {{ {state with data_conn = None} }}
217 send(OkFile "send");
218 wait_for_request(state)
219 | Some data ->
220 writeconn(conn2,data);
221 output_ascii_file_n(state,conn2,fd)
222 | None ->
223 send(ErrActNot);
224 wait_for_request(state)
225
226 % Send file to data port
227 receive_file(state,str):
228 if {{ state.passive }}
229 then
230 match {{ !(state.pasv_port_conn) }} with
231 | Some conn2 ->
232 output_ascii_file(state,str,conn2)
233 | None ->
234 {{ prerr_endline("receive_file: no pasv connection") }}
235 send(ErrNoFact);
236 else
237 connect({{state.data_port_spec,state.data_secure_mode}},output_ascii_file,state,str)
238 %let conn2 = connect(state.data_port_spec,Network.Unsecured)
239 %let state = {{ {state with data_conn = Some conn2} }}
240 %output_ascii_file(state,conn2,str)
241
242 % input_ascii_file:
243 % Given a connection and a filename, read the file contents from the link. As
244 % for output, we need to conform to the RFC 959 data conventions. Currently,
245 % we only do crlf conversion. The blocksize is also set in the state.
246 input_ascii_file(state,str,append,conn2):
247 let fd = {{ (if append then open_folder_append else open_folder_write) state str }}
248 %let bin = {{ get_binary_mode state }}
249 %send(BinConn bin);
250 send(OkFileConn str); % See RFC1123 4.1.2.9
251 input_ascii_file_n(state,conn2,str,fd)
252
253 input_ascii_file_n(state,conn2,str,fd):
254 let cnt_buff = readconn(conn2,state.data_blocksize);
255 let cnt = {{ fst cnt_buff }}
256 if {{ cnt > 0 }}
257 then
258 let buff = {{ snd cnt_buff }}
259 let _ = {{ write_folder state fd buff cnt }}
260 input_ascii_file_n(state,conn2,str,fd)
261 else
262 {{ close_folder fd }}
263 {{ Scheduler.remove_connection sched conn2 }}
264 let state = {{ {state with data_conn = None} }}
265 let msg = {{ (sprintf "%s received" str) }}
266 send(OkFile msg);
267 wait_for_request(state)
268
269 % Stuff incoming data into the named file
270 store_file(state,str,append):
271 if {{ state.passive }}
272 then
273 match {{ !(state.pasv_port_conn) }} with
274 | Some conn2 ->
275 input_ascii_file(state,str,append,conn2)
276 | None ->
277 {{ prerr_endline("store_file: no pasv connection") }}
278 send(ErrNoFact);
279 else
280 connect({{state.data_port_spec,state.data_secure_mode}},input_ascii_file,state,str,append)
281 %let conn2 = connect(state.data_port_spec,Network.Unsecured)
282 %let state = {{ {state with data_conn = Some conn2} }}
283 %input_ascii_file(state,conn2,str,append)
284
285 % Change directory
286 change_dir(state,str):
287 if {{ valid_folder state str }}
288 then
289 if {{ cwd state str }}
290 then
291 let str = {{ pwd state }}
292 send(OkCwd str);
293 wait_for_request(state)
294 else
295 send(ErrCwd);
296 wait_for_request(state)
297 else
298 send(ErrCwd);
299 wait_for_request(state)
300
301 % Construct a standard help message
302 transmit_help(state):
303 send(OkHelp1);
304 let msg = {{ recognized_commands 10 }}
305 send(Dummy msg);
306 send(OkHelp2);
307 wait_for_request(state)
308
309 % Generalised file/dir action
310 file_action(state,pathname,action):
311 if {{ valid_folder state pathname }}
312 then
313 if {{ action state pathname }}
314 then
315 send(OkFileAct);
316 wait_for_request(state)
317 else
318 send(ErrNoFact);
319 wait_for_request(state)
320 else
321 send(ErrPerm);
322 wait_for_request(state)
323
324 wait_for_request(state):
325 let state = {{ {state with rename_string=None; start_position=0} }}
326 do_wait_for_request(state)
327
328 do_wait_for_request(state):
329 receive
330
331 % Send list of files - currently not implemented
332 | List ->
333 let str = {{ Filename.current_dir_name }}
334 process_nlst(state, str, ls_file)
335 | ListS str ->
336 process_nlst(state, str, ls_file)
337
338 % Return directory listing
339 | Nlst ->
340 let str = {{ Filename.current_dir_name }}
341 process_nlst(state, str, plain_file)
342 | NlstS str ->
343 process_nlst(state, str, plain_file)
344
345 % Change current directory
346 | Cwd str ->
347 if {{ str = "/" }} % <- explicit_path this !!!
348 then
349 let str = {{ state.default_folder }}
350 change_dir(state,str)
351 else
352 change_dir(state,str)
353
354 % Change current directory
355 | Cwd0 ->
356 let str = {{ Filename.current_dir_name }}
357 change_dir(state,str)
358
359 % Change current directory
360 | CwdX ->
361 let str = {{ Filename.current_dir_name }}
362 change_dir(state,str)
363
364 % Change to parent directory
365 | Cdup ->
366 let str = {{ Filename.parent_dir_name }}
367 change_dir(state,str)
368
369 % Return current directory
370 | Pwd ->
371 let s = {{ pwd state }}
372 send(OkPwd s);
373 wait_for_request(state)
374
375 % Go into passive mode
376 | Pasv ->
377 match {{ get_passive_port state sched }} with
378 | (state, Some (portstr,port_spec_opt,sec_mode_opt)) ->
379 let port_sec_opt = {{
380 match port_spec_opt,sec_mode_opt with
381 | ((Some port_spec),(Some sec_mode)) -> Some (port_spec,sec_mode)
382 | ((Some port_spec),None) -> Some (port_spec,Network.Unsecured)
383 | (None,_) -> None
384 }}
385 begin
386 match {{ port_sec_opt }} with
387 | Some port_sec ->
388 let _key = listen({{port_sec}},set_pasv_port_conn,state) ;
389 send(OkPasv portstr);
390 let state = {{ { state with passive = true } }}
391 {{ prerr_endline (sprintf "Passive mode %b" state.passive) }}
392 wait_for_request(state)
393 | None ->
394 {{ prerr_endline (sprintf "Couldn't enter passive mode\n") }}
395 wait_for_request(state)
396 end
397 | (state, None) ->
398 % What do we send here??? Nothing in RFC959
399 {{ prerr_endline (sprintf "Couldn't enter passive mode\n") }}
400 wait_for_request(state)
401 ;
402
403 % Define the data port, addr and port no.
404 | Port str ->
405 let state_ok = {{ set_port state str }}
406 let state = {{ fst state_ok }}
407 if {{ snd state_ok }}
408 then
409 send(OkCmd "Port Command Accepted");
410 wait_for_request(state)
411 else
412 send(ErrSyntax2);
413 wait_for_request(state)
414 end
415
416 % Set the transfer type
417 | Type str ->
418 let state_msg = {{ set_type state str }}
419 let state = {{ fst state_msg }}
420 let msg = {{ snd state_msg }}
421 if {{ msg = "200" }} then
422 send(OkCmd "Command okay.");
423 wait_for_request(state)
424 else if {{ msg = "501" }} then
425 send(ErrSyntax2);
426 wait_for_request(state)
427 else
428 send(ErrNoimp);
429 wait_for_request(state)
430
431 % Set the data structure
432 | Stru str ->
433 let state_msg = {{ set_structure_code state str }}
434 let state = {{ fst state_msg }}
435 let msg = {{ snd state_msg }}
436 if {{ msg = "200" }} then
437 send(OkCmd "Command okay.");
438 wait_for_request(state)
439 else if {{ msg = "501" }} then
440 send(ErrSyntax2);
441 wait_for_request(state)
442 else
443 send(ErrNoimp);
444 wait_for_request(state)
445
446 % Set the transfer mode
447 | Mode str ->
448 match {{ set_transfer_mode state str }} with
449 | (state,"200") ->
450 send(OkCmd "Command okay.");
451 wait_for_request(state)
452 | (state,"501") ->
453 send(ErrSyntax2);
454 wait_for_request(state)
455 | (state,_) ->
456 send(ErrNoimp);
457 wait_for_request(state)
458 ;
459
460 % Send file down data port
461 | Retr str ->
462 receive_file(state,str)
463
464 % An RETR with no argument, don't look at me, firefox does this !!!
465 | RetrX ->
466 send(ErrFailOpen);
467 wait_for_request(state)
468
469 % Read file from data port
470 | Stor str ->
471 store_file(state,str,false)
472
473 % Append file read from data port
474 | Appe str ->
475 store_file(state,str,true)
476
477 % Read unique file from data port
478 % RFC959 says no argument but some ftps seem to send one anyway...
479 | Stou ->
480 let str = {{ get_unique_filename (Folder.current_folder state.folder) "ftp_" "" }}
481 store_file(state,str,false)
482 | StouS str1 ->
483 let str = {{ get_unique_filename (Folder.current_folder state.folder) (str1^"_") "" }}
484 store_file(state,str,false)
485
486 | Rest str ->
487 match {{ set_start_position state str }} with
488 | (state,numstr) ->
489 send(ReqRest numstr);
490 do_wait_for_request(state)
491 ;
492
493 % Rename file, part I
494 | Rnfr str ->
495 if {{ valid_folder state str && writable_folder state str }}
496 then
497 let state = {{ {state with rename_string=Some str} }}
498 send(ReqPend);
499 do_wait_for_request(state)
500 else
501 send(ErrPerm);
502 wait_for_request(state)
503
504 % Rename file, part II
505 | Rnto str ->
506 if {{ Option.is_some(state.rename_string) }}
507 then
508 if {{ valid_folder state str }}
509 then
510 if {{ rename_folder state (Option.get state.rename_string) str }}
511 then
512 send(OkFileAct);
513 wait_for_request(state)
514 else
515 send(ErrPerm);
516 wait_for_request(state)
517 else
518 send(ErrPerm);
519 wait_for_request(state)
520 else
521 send(ErrBadSeq);
522 wait_for_request(state)
523
524 % Delete file
525 | Dele str ->
526 file_action(state,str,delete_folder)
527
528 % Create directory.
529 | Mkd str ->
530 file_action(state,str,create_directory)
531
532 % Create directory.*)
533 | Rmd str ->
534 file_action(state,str,delete_directory)
535
536 % System type, just send the usual UNIX one.
537 | Syst ->
538 send(OkSyst);
539 wait_for_request(state)
540
541 % System type, just send the usual UNIX one.
542 | Stat ->
543 send(OkStat211a);
544 let statstr = {{ server_status state conn }}
545 send(Dummy statstr);
546 send(OkStat211b);
547 wait_for_request(state)
548
549 % Seems to be redundant
550 | Allo1 ->
551 send(OkAllo);
552 wait_for_request(state)
553 | Allo2 _ ->
554 send(OkAllo);
555 wait_for_request(state)
556 | Allo3 _ ->
557 send(OkAllo);
558 wait_for_request(state)
559
560 % File size, with no argument???
561 | Size ->
562 send(ErrNoSize);
563 wait_for_request(state)
564
565 % File size, as it would be transmitted
566 | SizeS _ ->
567 send(ErrNoSize);
568 wait_for_request(state)
569
570 % File mdtm, with no argument???
571 | Mdtm ->
572 send(ErrNoMdtm);
573 wait_for_request(state)
574
575 % File modification time
576 | MdtmS _ ->
577 send(ErrNoMdtm);
578 wait_for_request(state)
579
580 % Help string, just send implemented commands.
581 | Help ->
582 transmit_help(state)
583
584 | HelpS _ ->
585 transmit_help(state)
586
587 % Account, not implemented.
588 | Acct _ ->
589 send(ErrAcct);
590 wait_for_request(state)
591
592 % Do nothing, but it's in the minimal spec.
593 | Noop ->
594 send(OkCmd "Command okay.");
595 wait_for_request(state)
596
597 % Terminate the current connection
598 | Quit ->
599 let str = {{ state.goodbye_message }}
600 send(Bye str);
601 -!-
602
603 % Catchall, we need this to pick up bad commands
604 | _ ->
605 send(ErrSyntax);
606 wait_for_request(state)
607
608 % Timeout
609 after state.timeout ->
610 send(ErrTime);
611 let str = {{ state.goodbye_message }}
612 send(Bye str);
613 -!-
614
615 set_pasv_port_conn(state):
616 let _ = {{ sched }}
617 {{ state.pasv_port_conn := Some conn }}
618
619 %listen_port2(state):
620 % receive
621 % | Other str ->
622 % {{ prerr_endline (sprintf "listen_port2: received %s" str) }}
623 % -!-
624 % catch
625 % | exn ->
626 % {{ prerr_endline (sprintf "listen_port2: caught %s" (Printexc.to_string exn)) }}
627
628 % end of file
Something went wrong with that request. Please try again.