ftpdata.pas

Source code Delphi FTP-server

{$A+,B-,C+,D+,E-,F-,G+,H-,I-,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
unit FtpData;

{--------------------------------------------------------------------}
{ FtpData module. Data transfer protocols.                           }
{ 12/09/1999 Drt.                                                    }
{--------------------------------------------------------------------}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  WinSock, TrdBase, GetWrd, FtpObj;

const
 MTU = 1024;

type
 trecvbuf = array [1..MTU] of byte;

type
 TDataThread = class (TFtpThreades)
 public
   DState : TDataState;
   RAddr  : TAddr;
   Pasv   : boolean;
   Dir    : TDirection;
   Mode   : TMode;
   Stream : TStream;
   List   : TListFiller;
   Marker : string[24];
   Res    : boolean;
   ControlLog : TCallLogEvent;
   constructor Create(AFName : string; ARAddr : TAddr; APasv : boolean;
     ADir : TDirection; AMode : TMode; AStream : TStream; APort : integer;
     AParent : TFtpComponent; AList : TListFiller; AMarker : string;
     PExit : TNotifyEvent; AControlLog : TCallLogEvent; AUsr,APwd,ACDir : string);
   procedure GotWork(AFName : string; ADir : TDirection; AMode : TMode;
     AStream : TStream; AList : TListFiller; AMarker : string);
   procedure Terminate;
 private
   procedure execute; override;
   procedure DataConnect;
   procedure HandleError(ErrNo : integer);
   procedure LogMessage(MsgNo : integer);
   procedure Synchronized;
   procedure SendFile;
   procedure SendList;
   procedure ReceiveFile(AAppend : boolean);
   end;

implementation

constructor TDataThread.create;
begin
inherited create(true);
Cmd:='';
Par:='';
Usr:=AUsr;
Pwd:=APwd;
CDir:=ACDir;
ControlLog:=AControlLog;
Parent:=AParent;
DState:=ds_NoFile;
FName:=AFName;
RAddr:=ARAddr;
Pasv:=APasv;
Dir:=ADir;
Mode:=AMode;
Stream:=AStream;
List:=AList;
Port:=APort;
Error:=0;
OnTerminate:=PExit;
Marker:=AMarker;
FreeOnTerminate:=true;
Resume;
end;

procedure TDataThread.GotWork;
begin
suspend;
DState:=ds_NoFile;
Dir:=ADir;
Mode:=AMode;
Stream:=AStream;
List:=AList;
Error:=0;
Marker:=AMarker;
FName:=AFName;
resume;
end;

procedure TDataThread.Terminate;
begin
Shutdown(CSocket,2);
CloseSocket(CSocket);
inherited Terminate;
end;

procedure TDataThread.HandleError(ErrNo : integer);
begin
Error:=ErrNo;
LogMessage(ErrNo);
end;

procedure TDataThread.Synchronized;
begin
if assigned(ControlLog) then ControlLog(self,Res);
end;

procedure TDataThread.LogMessage(MsgNo : integer);
begin
Messg:=MsgNo;
Synchronize(Synchronized);
Error:=0;
Messg:=0;
end;

type
 tba = array [1..4] of byte;

procedure TDataThread.DataConnect;
var
 prt : word;
 P   : pProtoEnt;
 len : integer;
 sct : integer;
begin
prt:=htons(Port);
P:=GetProtoByName('TCP');
if P = nil then
  begin
  HandleError(WSAGetLastError);
  Terminate;
  exit;
  end;
bzero(sin,sizeof(sin));
sin.sin_family:=AF_INET;
sin.sin_port:=prt;
if pasv then
  begin
  sct:=socket(AF_INET,SOCK_STREAM,P^.p_proto);
  if sct < 0 then
    begin
    HandleError(WSAGetLastError);
    Terminate;
    exit;
    end;
  if bind(sct,tsockaddr(sin),sizeof(sin)) < 0 then
    begin
    HandleError(WSAGetLastError);
    Terminate;
    exit;
    end;
  if listen(sct,4) < 0 then
    begin
    HandleError(WSAGetLastError);
    Terminate;
    exit;
    end;
  LogMessage(DS_LISTEN);
  len:=sizeof(sin);
  CSocket:=accept(sct,@tsockaddr(sin),@len);
  shutdown(sct,2);
  closesocket(sct);
  if CSocket <= 0 then
    begin
    HandleError(WSAGetLastError);
    terminate;
    exit;
    end;
  RAddr:=TAddr(sin.sin_addr.s_un_b);
  LogMessage(DS_ACCEPT);
  end
else
  begin
  tba(sin.sin_addr)[1]:=RAddr[1];
  tba(sin.sin_addr)[2]:=RAddr[2];
  tba(sin.sin_addr)[3]:=RAddr[3];
  tba(sin.sin_addr)[4]:=RAddr[4];
  CSocket:=socket(AF_INET,SOCK_STREAM,P^.p_proto);
  if CSocket < 0 then
    begin
    HandleError(WSAGetLastError);
    Terminate;
    exit;
    end;
  LogMessage(DS_SOCKET);
  len:=sizeof(sin);
  if connect(CSocket,sin,len) = SOCKET_ERROR then
    begin
    HandleError(WSAGetLastError);
    terminate;
    exit;
    end;
  LogMessage(DS_CONNECT);
  end;
end;

procedure TDataThread.Execute;
begin
DataConnect;
while not terminated do
  begin
  case Dir of
    di_LIST, di_NLST:
      begin
      SendList;
      if Stream = dt_STREAM then
        begin
        terminate;
        exit;
        end;
      Dir:=di_IDLE;
      end;
    di_SEND:
      begin
      SendFile;
      if Stream = dt_STREAM then
        begin
        terminate;
        exit;
        end;
      Dir:=di_IDLE;
      end;
    di_RECEIVE:
      begin
      ReceiveFile(false);
      if Stream = dt_STREAM then
        begin
        terminate;
        exit;
        end;
      Dir:=di_IDLE;
      end;
    di_APPEND:
      begin
      ReceiveFile(true);
      if Stream = dt_STREAM then
        begin
        terminate;
        exit;
        end;
      Dir:=di_IDLE;
      end;
    else
      sleep(100);
    end;
  end;
end;

procedure TDataThread.SendList;
var
 sss : string[200];
 i   : integer;
begin
for i:=0 to List.Count-1 do
  begin
  if length(List[i]) <> 0 then
    begin
    sss:=List[i]+#13#10;
    if FileWrite(CSocket,sss[1],length(sss)) <> length(sss) then
      begin
      HandleError(WSAGetLastError);
      terminate;
      exit;
      end;
    end;
  end;
end;

var
 b : trecvbuf;

procedure TDataThread.SendFile;
var
 i   : integer;
 f   : file;
 l   : longint;
begin
DState:=ds_START;
filemode:=$40;
assignfile(f,FName);
reset(f,1);
i:=ioresult;
if i <> 0 then
  begin
  HandleError(DS_FOPEN);
  terminate;
  exit;
  end;
DState:=ds_Progress;
if Marker <> '0' then
  begin
  val(Marker,l,i);
  if (i > 0) or (l > filesize(f)) then
    begin
    HandleError(DS_BADMRK);
    terminate;
    exit;
    end;
  seek(f,l);
  end;
blockread(f,b,MTU,i);
if ioresult <> 0 then
  begin
  HandleError(DS_FREAD);
  closefile(f);
  ioresult;
  terminate;
  exit;
  end;
while not terminated and (i = MTU) do
  begin
  if send(CSocket,b,MTU,0) <> MTU then
    begin
    HandleError(DS_SWRITE);
    closefile(f);
    ioresult;
    terminate;
    exit;
    end;
  blockread(f,b,MTU,i);
  if ioresult <> 0 then
    begin
    HandleError(DS_FREAD);
    closefile(f);
    ioresult;
    terminate;
    exit;
    end;
  end;
if send(CSocket,b,i,0) <> i then
  begin
  HandleError(DS_SWRITE);
  closefile(f);
  ioresult;
  terminate;
  exit;
  end;
DState:=ds_Finished;
closefile(f);
ioresult;
DState:=ds_NoFile;
end;

procedure TDataThread.ReceiveFile(AAppend : boolean);
var
 i  : integer;
 f  : file;
 l  : longint;
begin
DState:=ds_START;
filemode:=$43;
assignfile(f,FName);
if AAppend then
  begin
  reset(f,1);
  if ioresult = 0 then
    seek(f,filesize(f))
  else
    rewrite(f,1)
  end
else
  begin
  if Marker <> '0' then
    begin
    reset(f,1);
    if ioresult <> 0 then
      rewrite(f,1)
    else
      begin
      val(Marker,l,i);
      if (i > 0) or (l > filesize(f)) then
        begin
        HandleError(DS_BADMRK);
        terminate;
        exit;
        end;
      seek(f,l);
      end;
    end
  else
    rewrite(f,1);
  end;
i:=ioresult;
if i <> 0 then
  begin
  HandleError(DS_FCREATE);
  DState:=ds_NoFile;
  terminate;
  exit;
  end;
DState:=ds_Progress;
while not terminated do
  begin
  i:=recv(CSocket,b,MTU,0);
  if i <= 0 then
    begin
    DState:=ds_Finished;
    closefile(f);
    ioresult;
    DState:=ds_NoFile;
    terminate;
    exit;
    end;
  blockwrite(f,b,i);
  if ioresult <> 0 then
    begin
    closefile(f);
    ioresult;
    HandleError(DS_FWRITE);
    DState:=ds_NoFile;
    terminate;
    exit;
    end;
  end;
DState:=ds_NoFile;
closefile(f);
ioresult;
end;

end.