srvctrl.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 SrvCtrl;

{--------------------------------------------------------------------}
{ SrvCtrl module. FTP command processor.                             }
{ 11/15/1999 Drt.                                                    }
{--------------------------------------------------------------------}

interface

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

const
 st_LOGIN  = 1;
 st_AUTH   = 2;
 st_DIALOG = 3;
 st_DATA   = 4;

type
  TSrvCtrlThread = class (TFtpThreades)
  private
    CB    : TCB;
    RdTrd : TReadThread;
    DTrd  : TDataThread;
    CMode : TMode;
    CData : TStream;
    LPort : integer;
    DPort : integer;
    HName : string[100];
    HAddr : TAddr;
    Pasv  : boolean;
    DCon  : boolean;
    TOut  : TTimeout;
    Brk   : boolean;
    Res   : boolean;
    Marker: string[20];
    procedure Execute; override;
    procedure SendString(s : string);
    function CmdSwitch(Cmd : string) : integer;
    function ExpandMacros(s : string) : string;
    procedure RdExit(Sender : TObject);
    procedure DConExit(Sender : TObject);
    procedure HandleError(ErrNo : integer);
    procedure LogMessage(MsgNo : integer);
    procedure Synchronized;
    function InsertProcess : boolean;
  public
    ControlLog : TCallLogEvent;
    constructor create(ASocket : integer; ACallLogEvent : TCallLogEvent; AParent : TFtpComponent;
      ARAddr : TAddr);
    destructor Destroy; override;
    procedure Terminate;
    end;

 TProcessList = array [1..MaxConn] of TSrvCtrlThread;

var
 ProcessList  : TProcessList;

implementation

constructor TSrvCtrlThread.create;
var
 HE : phostent;
 c  : string[5];
begin
inherited create(true);
PID:=0;
CSocket:=ASocket;
ControlLog:=ACallLogEvent;
State:=st_LOGIN;
Parent:=AParent;
PType:=tt_Control;
CDir:='';
FName:='';
CMode:=Parent.Mode;
CData:=dt_STREAM;
DPort:=Parent.DataPort;
Pasv:=false;
DCon:=false;
Marker:='0';
CB:=TCB.Create;
FreeOnTerminate:=true;
if CB = nil then
  begin
  HandleError(ES_NOMEM);
  terminate;
  exit;
  end;
RdTrd:=TReadThread.Create(CSocket,CB);
RdTrd.OnTerminate:=RdExit;
GetHostName(@HName[1],99);
HName[0]:=char(strlen(@HName[1]));
HE:=GetHostByName(@HName[1]);
c:=copy(strpas(HE^.h_addr_list^),1,4);
HAddr[1]:=byte(c[1]);
HAddr[2]:=byte(c[2]);
HAddr[3]:=byte(c[3]);
HAddr[4]:=byte(c[4]);
RAddr:=ARAddr;
if not InsertProcess then
  begin
  SendString('421 Max. number of connection exceeded'#13#10);
  sleep(200);
  terminate;
  exit;
  end;
Res:=true;
LogMessage(CS_START);
if not Res then
  begin
  terminate;
  exit;
  end;
Resume;
end;

destructor TSrvCtrlThread.Destroy;
begin
LogMessage(CS_TERM);
sleep(200);
if PID > 0 then ProcessList[PID]:=nil;
CB.Destroy;
inherited Destroy;
end;

procedure TSrvCtrlThread.Terminate;
begin
Shutdown(CSocket,2);
CloseSocket(CSocket);
RdTrd.Terminate;
if DCon then
  DTrd.Terminate;
inherited Terminate;
end;

procedure TSrvCtrlThread.DConExit;
begin
DCon:=false;
Marker:='0';
LogMessage(DS_CLOSE);
end;

function TSrvCtrlThread.InsertProcess : boolean;
var
 i : word;
begin
result:=false;
for i:=1 to parent.MaxConn do
  begin
  if ProcessList[i] = nil then
    begin
    ProcessList[i]:=self;
    PID:=i;
    result:=true;
    exit;
    end;
  end;
end;

procedure TSrvCtrlThread.RdExit;
begin
terminate;
end;

function TSrvCtrlThread.ExpandMacros(s : string) : string;
var
 i,j : integer;
 n,l : integer;
 str : string[130];
 caps: boolean;
begin
caps:=false;
i:=pos('%u',s);
if i = 0 then
  begin
  i:=pos('%U',s);
  caps:=true;
  end;
while i > 0 do
  begin
  n:=0;
  l:=2;
  if i > 0 then
    begin
    if s[i+2] = ':' then
      begin
      l:=3;
      for j:=3 to 5 do
        begin
        if s[i+j] in ['0'..'9'] then
          begin
          n:=n*10+(byte(s[i+j])-$30);
          inc(l);
          end
        else
          break;
        end;
      end;
    delete(s,i,l);
    if Caps then
      insert(stupcase(Usr)+space(n-length(Usr)),s,i)
    else
      insert(Usr+space(n-length(Usr)),s,i);
    end;
  caps:=false;
  i:=pos('%u',s);
  if i = 0 then
    begin
    i:=pos('%U',s);
    caps:=true;
    end;
  end;
caps:=false;
i:=pos('%h',s);
if i = 0 then
  begin
  i:=pos('%H',s);
  caps:=true;
  end;
if i > 0 then
  begin
  j:=Parent.UserList.IndexOf(Usr);
  str:='';
  if (j >=0) and (j < Parent.UserList.Count) then str:=Parent.UserList.Home[j];
  end;
while i > 0 do
  begin
  n:=0;
  l:=2;
  if i > 0 then
    begin
    if s[i+2] = ':' then
      begin
      l:=3;
      for j:=3 to 5 do
        begin
        if s[i+j] in ['0'..'9'] then
          begin
          n:=n*10+(byte(s[i+j])-$30);
          inc(l);
          end
        else
          break;
        end;
      end;
    delete(s,i,l);
    if caps then
      insert(stupcase(str)+space(n-length(str)),s,i)
    else
      insert(str+space(n-length(str)),s,i);
    end;
  caps:=false;
  i:=pos('%h',s);
  if i = 0 then
    begin
    i:=pos('%H',s);
    caps:=true;
    end;
  end;
result:=s;
end;

function TSrvCtrlThread.CmdSwitch(Cmd : string) : integer;
begin
result:=-1;
if Cmd = 'NOOP' then result:=0;
if Cmd = 'USER' then result:=1;
if Cmd = 'PASS' then result:=2;
if Cmd = 'ACCT' then result:=3;
if Cmd = 'CWD'  then result:=4;
if Cmd = 'XCWD' then result:=4;
if Cmd = 'CDUP' then result:=5;
if Cmd = 'XCUP' then result:=5;
if Cmd = 'SMNT' then result:=6;
if Cmd = 'QUIT' then result:=7;
if Cmd = 'REIN' then result:=8;
if Cmd = 'PORT' then result:=9;
if Cmd = 'PASV' then result:=10;
if Cmd = 'TYPE' then result:=11;
if Cmd = 'STRU' then result:=12;
if Cmd = 'MODE' then result:=13;
if Cmd = 'RETR' then result:=14;
if Cmd = 'STOR' then result:=15;
if Cmd = 'STOU' then result:=16;
if Cmd = 'APPE' then result:=17;
if Cmd = 'ALLO' then result:=18;
if Cmd = 'REST' then result:=19;
if Cmd = 'RNFR' then result:=20;
if Cmd = 'RNTO' then result:=21;
if Cmd = 'ABOR' then result:=22;
if Cmd = 'DELE' then result:=23;
if Cmd = 'RMD'  then result:=24;
if Cmd = 'XRMD' then result:=24;
if Cmd = 'MKD'  then result:=25;
if Cmd = 'XMKD' then result:=25;
if Cmd = 'PWD'  then result:=26;
if Cmd = 'XPWD' then result:=26;
if Cmd = 'LIST' then result:=27;
if Cmd = 'NLST' then result:=28;
if Cmd = 'SITE' then result:=29;
if Cmd = 'SYST' then result:=30;
if Cmd = 'STAT' then result:=31;
if Cmd = 'HELP' then result:=32;
if Cmd = 'SIZE' then result:=33;
if Cmd = 'MDTM' then result:=34;
end;

procedure TSrvCtrlThread.SendString;
begin
s:=s+#13#10;
send(CSocket,s[1],byte(s[0]),0);
end;

var
 extint : longint;

procedure TSrvCtrlThread.Execute;
var
 i,i1: integer;
 s,s1: string[130];
 Ent : boolean;
 addr: TAddr;
 tprt: integer;
 tp2 : integer;
 lst : TListFiller;
 SR  : TSearchRec;
 lto : longint;
 rnfr: string[130];
 f   : file;
 ftm : FILETIME;
 lftm: FILETIME;
 stm : SYSTEMTIME;
begin
usr:='';
for i:=0 to Parent.BannerMsg.Count-2 do
  begin
  SendString('220-'+Parent.BannerMsg[i]);
  end;
SendString('220 '+Parent.BannerMsg[Parent.BannerMsg.Count-1]);
while not terminated do
  begin
  if CB.GetCB(cmd) then
    begin
    par:=trim(getend(cmd,2));
    cmd:=trim(stupcase(getword(cmd,1)));
    while (cmd <> '') and not (cmd[1] in ['a'..'z','A'..'Z','0'..'9']) do cmd:=copy(cmd,2,255);
    while (cmd <> '') and not (cmd[length(cmd)] in ['a'..'z','A'..'Z','0'..'9']) do dec(byte(cmd[0]));
    Res:=true;
    LogMessage(CS_COMMAND);
    if not Res then
      begin
      SendString('500 Prohibited by FtpMaster');
      continue;
      end;
    case CmdSwitch(cmd) of
      0 : { NOOP }
        begin
        SendString('200 Hi, how are you?');
        end;
      1 : { USER }
        begin
        usr:=alltrim(par);
        State:=st_AUTH;
        if (stupcase(usr) = 'FTP') or (stupcase(usr) = 'ANONYMOUS') then
          begin
          if Parent.AllowAnonymous then
            SendString('331 '+ExpandMacros(parent.FreePasswdMsg))
          else
            begin
            SendString('421 '+ExpandMacros(parent.NoAnonymousMsg));
            Terminate;
            exit;
            end;
          end
        else
          SendString('331 '+ExpandMacros(parent.PasswordMsg));
        end;
      2 : { PASS }
        begin
        if State <> st_AUTH then
          begin
          SendString('503 Expected USER');
          continue;
          end;
        i:=Parent.UserList.IndexOf(Usr);
        s:=#0#0;
        if (i >= 0) and (i < Parent.UserList.Count) then
          s:=Parent.UserList.Password[i];
        if (stupcase(usr) <> 'FTP') and (stupcase(usr) <> 'ANONYMOUS') then
          begin
          if par <> s then
            begin
            SendString(ExpandMacros('421 Authentification for user %u failed. Connection closed.'));
            Terminate;
            exit;
            end;
          end
        else
          Usr:='ftp';
        { Setting up the user environment }
        CDir:=Parent.UserList.HomeByName(Usr);
        if CDir = '' then
          begin
          if (stupcase(usr) = 'FTP') or (stupcase(usr) = 'ANONYMOUS') then
            CDir:='/'
          else