ftpServerCore.proto

-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