Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: v1056
Fetching contributors…

Cannot retrieve contributors at this time

629 lines (566 sloc) 17.965 kb
-generate server (* -*-erlang-*- *)
%
% Copyright © 2011 MLstate
%
% This file is part of OPA.
%
% OPA is free software: you can redistribute it and/or modify it under the
% terms of the GNU Affero General Public License, version 3, as published by
% the Free Software Foundation.
%
% OPA is distributed in the hope that it will be useful, but WITHOUT ANY
% WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
% FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
% more details.
%
% You should have received a copy of the GNU Affero General Public License
% along with OPA. If not, see <http://www.gnu.org/licenses/>.
%
-debugvar PROTOCOL_DEBUG
-protocol FTP
% ftpServer:
% o Conforms to RFC1123 updated minimal server requirements.
%
% TODO: (-=todo, /=partial, +=done)
% o RFC959
% + USER <SP> <username> <CRLF>
% + PASS <SP> <password> <CRLF>
% + ACCT <SP> <account-information> <CRLF>
% + CWD <SP> <pathname> <CRLF>
% + CDUP <CRLF>
% - SMNT <SP> <pathname> <CRLF>
% + QUIT <CRLF>
% - REIN <CRLF>
% + PORT <SP> <host-port> <CRLF>
% + PASV <CRLF>
% / TYPE <SP> <type-code> <CRLF>
% / STRU <SP> <structure-code> <CRLF>
% / MODE <SP> <mode-code> <CRLF>
% + RETR <SP> <pathname> <CRLF>
% + STOR <SP> <pathname> <CRLF>
% + STOU <CRLF>
% + APPE <SP> <pathname> <CRLF>
% + ALLO <SP> <decimal-integer> [<SP> R <SP> <decimal-integer>] <CRLF>
% + REST <SP> <marker> <CRLF>
% + RNFR <SP> <pathname> <CRLF>
% + RNTO <SP> <pathname> <CRLF>
% - ABOR <CRLF>
% + DELE <SP> <pathname> <CRLF>
% + RMD <SP> <pathname> <CRLF>
% + MKD <SP> <pathname> <CRLF>
% + PWD <CRLF>
% + LIST [<SP> <pathname>] <CRLF>
% + NLST [<SP> <pathname>] <CRLF>
% - SITE <SP> <string> <CRLF>
% + SYST <CRLF>
% / STAT [<SP> <pathname>] <CRLF>
% + HELP [<SP> <string>] <CRLF>
% + NOOP <CRLF>
% o RFC2389
% - FEAT <CRLF>
% - OPTS <SP> command-name [ <SP> command-options ] <CRLF>
% o RFC3659
% / SIZE <SP> <pathname> <CRLF>
% / MDTM <SP> <pathname> <CRLF>
% - REST
% - TVFS
% - MLST
% - MLSD
% o all commands in no login
% o records
% o stat for files/dirs
% o check for RFC1123 errata compliance
-open Printf
-open FtpServerType
-include "libnet/ftpResponses.proto"
-include "libnet/ftpMessages.proto"
-type payload = unit
-include "libnet/rt_proto.proto"
-type runtime = {
rt_plim : int;
rt_dialog_name : string;
rt_on_close : Scheduler.t -> unit;
rt_proto : rt_proto;
}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% General states %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+on_connection(state : FtpServerType.state):
{{ Printf.eprintf "on_connection\n" }}
% listen ({{ (Network.make_port_spec (Unix.inet_addr_of_string "127.0.0.1") 12345 Network.Unsecured) }}, listen_port2) ;
let hello = {{ get_hello_message state }}
send(Dummy hello);
wait_for_login(state)
wait_for_login(state):
receive
| User str ->
if {{ str = "admin" }} then
let state = {{ {state with is_admin = true; user = Some str} }}
send(ReqPass str);
wait_for_pass(state)
else
let state = {{ {state with is_admin = false; user = Some str} }}
send(OkLogin);
wait_for_request(state)
| Syst ->
{{ Printf.eprintf "Syst\n%!" }}
send(OkSyst);
wait_for_login(state)
| Quit ->
let str = {{ state.goodbye_message }}
send(Bye str);
-!-
| msg ->
{{ Printf.eprintf "Error %s\n%!" (string_of_msg msg) }}
send(ErrLogin);
wait_for_login(state)
after state.timeout ->
send(ErrTime);
let str = {{ state.goodbye_message }}
send(Bye str);
-!-
wait_for_pass(state):
receive
| Pass str ->
if {{ (str = "mlstate") }}
then
send(OkLogin);
let state = {{ {state with is_admin = true} }}
let _ = {{ cwd state state.default_folder }}
wait_for_request(state)
else
send(ErrPass);
let state = {{ {state with is_admin = false; user = None} }}
wait_for_login(state)
| _ -> send(ErrSyntax);
wait_for_login(state)
after state.timeout ->
send(ErrTime);
wait_for_login(state);
% process_nlst:
% Open a connection to the current data_port_spec in the state and
% read the given directory's content. Dump a list of files
% down the link turning \n into \r\n if in ASCII mode.
%
process_nlst(state,str,list_fn):
let nlst_ok = {{ list state.folder str list_fn }}
let nlst = {{ fst nlst_ok }}
if {{ snd nlst_ok }} then
if {{ state.passive }}
then
send(DirList);
match {{ !state.pasv_port_conn }} with
| Some conn2 ->
writeconn(conn2,nlst);
{{ Scheduler.remove_connection sched conn2 }}
{{ state.pasv_port_conn := None }}
send(OkDir);
wait_for_request(state)
| None ->
{{ prerr_endline("process_nlst: no pasv connection") }}
send(ErrNoFact);
wait_for_request(state)
;
else
connect({{state.data_port_spec,state.data_secure_mode}},process_nlst_pasv,state,nlst)
%let conn2 = connect(state.data_port_spec,Network.Unsecured);
%let state = {{ {state with data_conn = Some conn2} }}
%send(DirList);
%writeconn(conn2,nlst);
%send(OkDir);
%{{ Scheduler.remove_connection sched conn2 }}
%let state = {{ {state with data_conn = None} }}
%wait_for_request(state)
else
send(ErrNoFact);
wait_for_request(state)
end
process_nlst_pasv(state,nlst,conn2):
send(DirList);
writeconn(conn2,nlst);
send(OkDir);
{{ Scheduler.remove_connection sched conn2 }}
let state = {{ {state with data_conn = None} }}
wait_for_request(state)
% output_ascii_file:
% Given a connection and a filename, dump the file contents down the link. We
% need to take care with the RFC 959 data conventions. Currently, we only do
% crlf conversion. The blocksize is set in the state.
output_ascii_file(state,str,conn2):
match {{ open_folder_read state str }} with
| Some fd ->
let bin = {{ get_binary_mode state }}
send(BinConn bin);
output_ascii_file_n(state,conn2,fd)
| None ->
send(ErrFailOpen);
wait_for_request(state)
output_ascii_file_n(state,conn2,fd):
match {{ read_folder state fd state.data_blocksize }} with
| Some "" ->
{{ close_folder fd }}
{{ Scheduler.remove_connection sched conn2 }}
let state = {{ {state with data_conn = None} }}
send(OkFile "send");
wait_for_request(state)
| Some data ->
writeconn(conn2,data);
output_ascii_file_n(state,conn2,fd)
| None ->
send(ErrActNot);
wait_for_request(state)
% Send file to data port
receive_file(state,str):
if {{ state.passive }}
then
match {{ !(state.pasv_port_conn) }} with
| Some conn2 ->
output_ascii_file(state,str,conn2)
| None ->
{{ prerr_endline("receive_file: no pasv connection") }}
send(ErrNoFact);
else
connect({{state.data_port_spec,state.data_secure_mode}},output_ascii_file,state,str)
%let conn2 = connect(state.data_port_spec,Network.Unsecured)
%let state = {{ {state with data_conn = Some conn2} }}
%output_ascii_file(state,conn2,str)
% input_ascii_file:
% Given a connection and a filename, read the file contents from the link. As
% for output, we need to conform to the RFC 959 data conventions. Currently,
% we only do crlf conversion. The blocksize is also set in the state.
input_ascii_file(state,str,append,conn2):
let fd = {{ (if append then open_folder_append else open_folder_write) state str }}
%let bin = {{ get_binary_mode state }}
%send(BinConn bin);
send(OkFileConn str); % See RFC1123 4.1.2.9
input_ascii_file_n(state,conn2,str,fd)
input_ascii_file_n(state,conn2,str,fd):
let cnt_buff = readconn(conn2,state.data_blocksize);
let cnt = {{ fst cnt_buff }}
if {{ cnt > 0 }}
then
let buff = {{ snd cnt_buff }}
let _ = {{ write_folder state fd buff cnt }}
input_ascii_file_n(state,conn2,str,fd)
else
{{ close_folder fd }}
{{ Scheduler.remove_connection sched conn2 }}
let state = {{ {state with data_conn = None} }}
let msg = {{ (sprintf "%s received" str) }}
send(OkFile msg);
wait_for_request(state)
% Stuff incoming data into the named file
store_file(state,str,append):
if {{ state.passive }}
then
match {{ !(state.pasv_port_conn) }} with
| Some conn2 ->
input_ascii_file(state,str,append,conn2)
| None ->
{{ prerr_endline("store_file: no pasv connection") }}
send(ErrNoFact);
else
connect({{state.data_port_spec,state.data_secure_mode}},input_ascii_file,state,str,append)
%let conn2 = connect(state.data_port_spec,Network.Unsecured)
%let state = {{ {state with data_conn = Some conn2} }}
%input_ascii_file(state,conn2,str,append)
% Change directory
change_dir(state,str):
if {{ valid_folder state str }}
then
if {{ cwd state str }}
then
let str = {{ pwd state }}
send(OkCwd str);
wait_for_request(state)
else
send(ErrCwd);
wait_for_request(state)
else
send(ErrCwd);
wait_for_request(state)
% Construct a standard help message
transmit_help(state):
send(OkHelp1);
let msg = {{ recognized_commands 10 }}
send(Dummy msg);
send(OkHelp2);
wait_for_request(state)
% Generalised file/dir action
file_action(state,pathname,action):
if {{ valid_folder state pathname }}
then
if {{ action state pathname }}
then
send(OkFileAct);
wait_for_request(state)
else
send(ErrNoFact);
wait_for_request(state)
else
send(ErrPerm);
wait_for_request(state)
wait_for_request(state):
let state = {{ {state with rename_string=None; start_position=0} }}
do_wait_for_request(state)
do_wait_for_request(state):
receive
% Send list of files - currently not implemented
| List ->
let str = {{ Filename.current_dir_name }}
process_nlst(state, str, ls_file)
| ListS str ->
process_nlst(state, str, ls_file)
% Return directory listing
| Nlst ->
let str = {{ Filename.current_dir_name }}
process_nlst(state, str, plain_file)
| NlstS str ->
process_nlst(state, str, plain_file)
% Change current directory
| Cwd str ->
if {{ str = "/" }} % <- explicit_path this !!!
then
let str = {{ state.default_folder }}
change_dir(state,str)
else
change_dir(state,str)
% Change current directory
| Cwd0 ->
let str = {{ Filename.current_dir_name }}
change_dir(state,str)
% Change current directory
| CwdX ->
let str = {{ Filename.current_dir_name }}
change_dir(state,str)
% Change to parent directory
| Cdup ->
let str = {{ Filename.parent_dir_name }}
change_dir(state,str)
% Return current directory
| Pwd ->
let s = {{ pwd state }}
send(OkPwd s);
wait_for_request(state)
% Go into passive mode
| Pasv ->
match {{ get_passive_port state sched }} with
| (state, Some (portstr,port_spec_opt,sec_mode_opt)) ->
let port_sec_opt = {{
match port_spec_opt,sec_mode_opt with
| ((Some port_spec),(Some sec_mode)) -> Some (port_spec,sec_mode)
| ((Some port_spec),None) -> Some (port_spec,Network.Unsecured)
| (None,_) -> None
}}
begin
match {{ port_sec_opt }} with
| Some port_sec ->
let _key = listen({{port_sec}},set_pasv_port_conn,state) ;
send(OkPasv portstr);
let state = {{ { state with passive = true } }}
{{ prerr_endline (sprintf "Passive mode %b" state.passive) }}
wait_for_request(state)
| None ->
{{ prerr_endline (sprintf "Couldn't enter passive mode\n") }}
wait_for_request(state)
end
| (state, None) ->
% What do we send here??? Nothing in RFC959
{{ prerr_endline (sprintf "Couldn't enter passive mode\n") }}
wait_for_request(state)
;
% Define the data port, addr and port no.
| Port str ->
let state_ok = {{ set_port state str }}
let state = {{ fst state_ok }}
if {{ snd state_ok }}
then
send(OkCmd "Port Command Accepted");
wait_for_request(state)
else
send(ErrSyntax2);
wait_for_request(state)
end
% Set the transfer type
| Type str ->
let state_msg = {{ set_type state str }}
let state = {{ fst state_msg }}
let msg = {{ snd state_msg }}
if {{ msg = "200" }} then
send(OkCmd "Command okay.");
wait_for_request(state)
else if {{ msg = "501" }} then
send(ErrSyntax2);
wait_for_request(state)
else
send(ErrNoimp);
wait_for_request(state)
% Set the data structure
| Stru str ->
let state_msg = {{ set_structure_code state str }}
let state = {{ fst state_msg }}
let msg = {{ snd state_msg }}
if {{ msg = "200" }} then
send(OkCmd "Command okay.");
wait_for_request(state)
else if {{ msg = "501" }} then
send(ErrSyntax2);
wait_for_request(state)
else
send(ErrNoimp);
wait_for_request(state)
% Set the transfer mode
| Mode str ->
match {{ set_transfer_mode state str }} with
| (state,"200") ->
send(OkCmd "Command okay.");
wait_for_request(state)
| (state,"501") ->
send(ErrSyntax2);
wait_for_request(state)
| (state,_) ->
send(ErrNoimp);
wait_for_request(state)
;
% Send file down data port
| Retr str ->
receive_file(state,str)
% An RETR with no argument, don't look at me, firefox does this !!!
| RetrX ->
send(ErrFailOpen);
wait_for_request(state)
% Read file from data port
| Stor str ->
store_file(state,str,false)
% Append file read from data port
| Appe str ->
store_file(state,str,true)
% Read unique file from data port
% RFC959 says no argument but some ftps seem to send one anyway...
| Stou ->
let str = {{ get_unique_filename (Folder.current_folder state.folder) "ftp_" "" }}
store_file(state,str,false)
| StouS str1 ->
let str = {{ get_unique_filename (Folder.current_folder state.folder) (str1^"_") "" }}
store_file(state,str,false)
| Rest str ->
match {{ set_start_position state str }} with
| (state,numstr) ->
send(ReqRest numstr);
do_wait_for_request(state)
;
% Rename file, part I
| Rnfr str ->
if {{ valid_folder state str && writable_folder state str }}
then
let state = {{ {state with rename_string=Some str} }}
send(ReqPend);
do_wait_for_request(state)
else
send(ErrPerm);
wait_for_request(state)
% Rename file, part II
| Rnto str ->
if {{ Option.is_some(state.rename_string) }}
then
if {{ valid_folder state str }}
then
if {{ rename_folder state (Option.get state.rename_string) str }}
then
send(OkFileAct);
wait_for_request(state)
else
send(ErrPerm);
wait_for_request(state)
else
send(ErrPerm);
wait_for_request(state)
else
send(ErrBadSeq);
wait_for_request(state)
% Delete file
| Dele str ->
file_action(state,str,delete_folder)
% Create directory.
| Mkd str ->
file_action(state,str,create_directory)
% Create directory.*)
| Rmd str ->
file_action(state,str,delete_directory)
% System type, just send the usual UNIX one.
| Syst ->
send(OkSyst);
wait_for_request(state)
% System type, just send the usual UNIX one.
| Stat ->
send(OkStat211a);
let statstr = {{ server_status state conn }}
send(Dummy statstr);
send(OkStat211b);
wait_for_request(state)
% Seems to be redundant
| Allo1 ->
send(OkAllo);
wait_for_request(state)
| Allo2 _ ->
send(OkAllo);
wait_for_request(state)
| Allo3 _ ->
send(OkAllo);
wait_for_request(state)
% File size, with no argument???
| Size ->
send(ErrNoSize);
wait_for_request(state)
% File size, as it would be transmitted
| SizeS _ ->
send(ErrNoSize);
wait_for_request(state)
% File mdtm, with no argument???
| Mdtm ->
send(ErrNoMdtm);
wait_for_request(state)
% File modification time
| MdtmS _ ->
send(ErrNoMdtm);
wait_for_request(state)
% Help string, just send implemented commands.
| Help ->
transmit_help(state)
| HelpS _ ->
transmit_help(state)
% Account, not implemented.
| Acct _ ->
send(ErrAcct);
wait_for_request(state)
% Do nothing, but it's in the minimal spec.
| Noop ->
send(OkCmd "Command okay.");
wait_for_request(state)
% Terminate the current connection
| Quit ->
let str = {{ state.goodbye_message }}
send(Bye str);
-!-
% Catchall, we need this to pick up bad commands
| _ ->
send(ErrSyntax);
wait_for_request(state)
% Timeout
after state.timeout ->
send(ErrTime);
let str = {{ state.goodbye_message }}
send(Bye str);
-!-
set_pasv_port_conn(state):
let _ = {{ sched }}
{{ state.pasv_port_conn := Some conn }}
%listen_port2(state):
% receive
% | Other str ->
% {{ prerr_endline (sprintf "listen_port2: received %s" str) }}
% -!-
% catch
% | exn ->
% {{ prerr_endline (sprintf "listen_port2: caught %s" (Printexc.to_string exn)) }}
% end of file
Jump to Line
Something went wrong with that request. Please try again.