trdbase.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 TrdBase;

{--------------------------------------------------------------------}
{ FtpBase module. Basic objects for all the FTP components.          }
{ 11/15/1999 Drt.                                                    }
{--------------------------------------------------------------------}

interface

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

const
  CM_START   = 1001;  { Main control thread has started }
  CM_LISTEN  = 1002;  { Main control thread is in the LISTEN state }
  CM_STOP    = 1003;  { Main control thread has forced to stop }
  CM_TERM    = 1004;  { Main control thread has terminated }

  SS_START   = 1101;
  SS_STOP    = 1102;

  CS_START   = 1201;  { Control thread has started }
  CS_TERM    = 1202;  { Control thread has terminated }
  CS_COMMAND = 1203;  { Control thread has received a command }
  CS_LOGIN   = 1204;
  CS_LOGOUT  = 1205;
  CS_CHDIR   = 1206;
  CS_DLOAD   = 1207;
  CS_ULOAD   = 1208;

  DS_LISTEN  = 1501;  { Data thread is in the LISTEN state }
  DS_SOCKET  = 1502;  { Data thread has created a socket }
  DS_CONNECT = 1503;  { Data thread has opened a connection }
  DS_ACCEPT  = 1504;  { Data thread has accepted incoming connection }
  DS_FOPEN   = 1505;  { Error open file }
  DS_FREAD   = 1506;  { File read error }
  DS_SWRITE  = 1507;  { Socket write error }
  DS_FCREATE = 1508;  { Error creating file }
  DS_FWRITE  = 1509;  { File write error }
  DS_CLOSE   = 1510;  { Data connection closed }
  DS_BADMRK  = 1511;  { Bad restart marker }

  ES_NOMEM   = 2201;  { Control thread is out of memory }
  ES_DRUN    = 2202;  { Can't stop data process }
  ES_STOUT   = 2203;  { The sending takes too much time }

const
 tt_Main     = 2001;
 tt_Control  = 2002;
 tt_Data     = 2003;
 tt_Read     = 2004;

 MaxConn = 1000;

type
  TMode = (md_ASCII, md_EBCDIC, md_IMAGE, md_LOCAL);
  TLsFmt = (lf_UNIX, lf_DOS, lf_Custom);
  TStream = (dt_STREAM);
  TDirection = (di_SEND, di_RECEIVE, di_APPEND, di_LIST, di_NLST,
    di_IDLE, di_EOJ);
  TDataState = (ds_Start, ds_Progress, ds_Finished, ds_NoFile);
  TAddr = array [1..4] of byte;
  TDirFile = set of (df_Directory, df_GrRead, df_GrWrite, df_GrExec,
    df_Read, df_Write, df_Exec);

  TFtpComponent = class (TComponent)
  protected
    FDirRestrict   : Boolean;
    FListFormat    : TLsFmt;
    FCustomList    : String;
    FMaxConn       : Integer;
    FFtpPort       : Integer;
    FDataPort      : Integer;
    FShowHidden    : Boolean;
    FShowReadOnly  : Boolean;
    FMode          : TMode;
    FAllowRedirect : Boolean;
    FAllowAnonymous: Boolean;
    FBannerMsg     : TStringList;
    FPasswordMsg   : string;
    FFreePasswdMsg : string;
    FNoAnonymousMsg: string;
    FCaseSensitive : Boolean;
  private
    procedure WBannerMsg(ABannerMsg : TStringList);
    procedure WListFormat(Value : TLsFmt);
    procedure WCustomList(Value : string);
  published
    { Properties }
    property DirRestrict   : Boolean read FDirRestrict write FDirRestrict;
    property ListFormat    : TLsFmt read FListFormat write WListFormat;
    property CustomList    : String read FCustomList write WCustomList;
    property MaxConn       : Integer read FMaxConn write FMaxConn;
    property FtpPort       : Integer read FFtpPort write FFtpPort;
    property DataPort      : Integer read FDataPort write FDataPort;
    property ShowHidden    : Boolean read FShowHidden write FShowHidden;
    property ShowReadOnly  : Boolean read FShowReadonly write FShowReadonly;
    property Mode          : TMode read FMode write FMode;
    property AllowRedirect : Boolean read FAllowRedirect write FAllowRedirect;
    property AllowAnonymous: Boolean read FAllowAnonymous write FAllowAnonymous;
    property BannerMsg     : TStringList read FBannerMsg write WBannerMsg;
    property PasswordMsg   : string read FPasswordMsg write FPasswordMsg;
    property FreePasswdMsg : string read FFreePasswdMsg write FFreePasswdMsg;
    property NoAnonymousMsg: string read FNoAnonymousMsg write FNoAnonymousMsg;
    property CaseSensitive : Boolean read FCaseSensitive write FCaseSensitive;
  public
    UserList : TUserList;
    GrpList  : TGrpList;
    DirList  : TDirList;
    end;

  TFtpThreades = class (TThread)
  public
    PID     : word;
    PType   : integer;
    Run     : boolean;
    CSocket : integer;
    Port    : word;
    Error   : integer;
    Messg   : integer;
    Parent  : TFtpComponent;
    sin     : TSockAddrIn;
    cmd     : string[130];
    par     : string[130];
    Usr     : string[30];
    Pwd     : string[30];
    CDir    : string[130];
    FName   : string[130];
    State   : integer;
    RAddr   : TAddr;
    end;

  TCallLogEvent = procedure(AThreade : TFtpThreades; var Result : boolean) of object;

  TReadThread = class (TFtpThreades)
  private
    CB : TCB;
    procedure Execute; override;
  public
    constructor Create(ASocket : integer; ACB : TCB);
    procedure Terminate;
    end;

  TListFiller = class (TStringList)
  public
    constructor Create;
    procedure FillFrom(Dir : string; LType : TDirection; User : string;
      Ftp : TFtpComponent);
  private
    function FormatLine(Name : string; NType : TDirFile; PDir : integer;
      Ftp : TFtpComponent; user,group : string; FDate : TFileTime;
      FSize : longint; UID,GID : word) : string;
    end;

procedure bzero(var b; n : word);

implementation

type
 tb = array [0..$fff0] of byte;

procedure bzero(var b; n : word);
begin
while n > 0 do
  begin
  tb(b)[n-1]:=0;
  dec(n);
  end;
end;

{ ---------- TFtpComponent ---------- }

procedure TFtpComponent.WBannerMsg(ABannerMsg : TStringList);
begin
FBannerMsg.Assign(ABannerMsg);
end;

procedure TFtpComponent.WListFormat(Value : TLsFmt);
begin
FListFormat:=Value;
case FListFormat of
  lf_UNIX: FCustomList:='%r %I:3 %g:9 %s:10 %d:12 %f';
  lf_DOS: FCustomList:='%F:14 %s:8 %d';
  lf_CUSTOM: FCustomList:='%r %u:8 %g:8 %s:8 %d:12 %F';
  end;
end;

procedure TFtpComponent.WCustomList(Value : string);
begin
FCustomList:=Value;
FListFormat:=lf_Custom;
end;

{ ---------- TReadThread ---------- }

constructor TReadThread.Create;
begin
inherited Create(true);
CB:=ACB;
CSocket:=ASocket;
FreeOnTerminate:=true;
Resume;
end;

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

procedure TReadThread.Execute;
var
 s : string;
begin
while not terminated do
  begin
  Error:=recv(CSocket,s[1],255,0);
  if (Error = SOCKET_ERROR) or (Error = 0) then
    begin
    shutdown(CSocket,2);
    closesocket(CSocket);
    terminate;
    exit;
    end;
  if terminated then exit;
  s[0]:=chr(Error);
  Error:=0;
  if not CB.AddCB(s) then
    begin
    terminate;
    exit;
    end;
  end;
end;

{ ---------- TListFiller ---------- }

constructor TListFiller.Create;
begin
inherited Create;
Sorted:=true;
Duplicates:=dupIgnore;
end;

procedure TListFiller.FillFrom(Dir : string; LType : TDirection; User : string;
  Ftp : TFtpComponent);
var
 i   : integer;
 j   : integer;
 p   : integer;
 s   : string[130];
 r   : TDirFile;
 r1  : TDirFile;
 ft  : TFileTime;
 SR  : TSearchRec;
 l   : longint;
 lnm : string[130];
 TDir: string[130];
 iusr: integer;
begin
clear;
Dir:=NormalizePath(Dir);
TDir:='';
p:=Ftp.DirList.IndexOf(Dir);
iusr:=Ftp.UserList.IndexOf(User);
if (iusr < 0) and not Ftp.AllowAnonymous then exit;
if p >= 0 then
  begin
  if iusr < 0 then
    begin
    if (Ftp.DirList.UID[p] = $ffff) and not (da_ReadList in Ftp.DirList.Attrib[p]) then exit;
    end
  else
    begin
    if (Ftp.DirList.UID[p] <> Ftp.UserList.UIDByName(User)) and not Ftp.UserList.RootByName(User) then
      begin
      if Ftp.UserList.InGroupByName(User,Ftp.DirList.GID[p]) then
        begin
        if not (da_GrReadList in Ftp.DirList.Attrib[p]) then exit;
        end
      else
        if not (da_ReadList in Ftp.DirList.Attrib[p]) then exit;
      end;
    end;
  end
else
  begin
  if Dir[length(Dir)] <> '/' then
    begin
    i:=length(Dir);
    while (i > 0) and (Dir[i] <> '/') do dec(i);
    if i > 0 then
      begin
      TDir:=copy(Dir,i+1,255);
      Dir[0]:=chr(i);
      end
    else
      begin
      TDir:=Dir;
      Dir:='/';
      end;
    p:=Ftp.DirList.IndexOf(Dir);
    if p >= 0 then
      begin
      if iusr < 0 then