dxftpbaseserver.pas

Well known and usefull component for delphi 7

unit DXFTPBaseServer;

interface

uses
  SysUtils, Classes, DXString, DxSock, DXSocket, DXServerCore, DXFTPServerCore,
  windows, dateutils;

Type
   TLogProc = procedure( ClientThread: TDXClientThread; Cmd : string ;parm1, parm2,parm3,parm4 :string) of object;
   TDXFTP_FILETRANSFER  = procedure( ClientThread: TDXClientThread; Store : Boolean; var Filename : string ;TotalBytes , CharPerSec : int64 )  of object;
   TDXFTP_PROCFILETRANSFER = procedure( ClientThread: TDXClientThread; TotalBytes, CurrBytes, ProcBytes : int64; var Abort : boolean   ) of object;
   TDXFTP_CLNTLST = function( ClientThread: TDXClientThread;List : TStrings ) : boolean  of object;
   TDXFTP_VALIDUSR = function(ClientThread: TDXClientThread; Username, Password : string ) : boolean   of object;

   PUserSession=^TUserSession;
   TUserSession=Record
{$IFDEF VER100}
      RestPos:Cardinal;
{$ELSE}
      RestPos:Int64;
{$ENDIF}
      AuthorizedState:Boolean;
      DataMode:Byte; {Ascii=0, Image=1}
      PASV:Boolean;
      DataSocket:TDXSock;
      User      :String;
      Pass      :String;
      Group     :String;
      CurrentDir:String; {must end with backslash!}
      HomeDir:String; {must end with backslash!}
      RNFO   :String;
      PeerIPAddress :String;
      NewConnect :TDXNewConnect; // in here for a little more speed!
      Abort : boolean ;
      LastFileSize : Int64;
      DiskQuotaKB : int64;
      DiskUsageKb : Int64;
      ReadOnly : boolean;
      FileXfer : boolean ;
      BytesRcv : int64 ;
      BytesSnd : int64 ;
      SpeedSend : integer;
      SpeedReceive : integer ;
      CurrSpeed : integer ;
      SpeedStartTS : TDateTime ;
      SpeedBytesXfer : integer ; //# Calc the transfer speed every 3 seconds
//      LastDataOp : TDateTime ;
      NoopCount : Integer ;
      UserData  : Tobject ;
   End;

type
{**
@abstract( Basic Implementation for a DXFtpserverCore )

The TDXFTPBaseServer implements the basic logic behind a FTP server
capable of handling several hundreds/thousands simultaneous
connections.
}
  TDXFTPBaseServer = class(TDXFTPServerCore)
  private
    FWorkLikeDos: boolean;
    fHomeDirIsRoot: boolean;
    FPasvMaxDataPort: integer;
    FPasvLowDataPort: integer;
    FDefaultDataPort: integer;
    FNextDataPort: Integer;
    fSameIPOnly : Boolean ;
    fNatAddress : string ;
    fUseNatAddr : boolean ;
    { Private declarations }
    feCReateSessionData : TDX_NewConnect ;
    feDestroySessionData: TDX_DestroySessionData;
    fLogProc        : TLogProc ;
    fuserHello      : TDXFTP_CLNTLST ;
    fuserBye        : TDXFTP_CLNTLST ;
    fInitGreet      : TDXFTP_CLNTLST ;
    fDisconnect     : TDX_NewConnect ;
    fTransferBegin  : TDXFTP_FILETRANSFER  ;
    fTransferEnd    : TDXFTP_FILETRANSFER;
    fValidateUser   : TDXFTP_VALIDUSR ;
    fAfterValidUser : TDXFTP_VALIDUSR ;

    feDataSocketOnRead  : TDXFTP_PROCFILETRANSFER;
    feDataSocketOnWrite : TDXFTP_PROCFILETRANSFER;

    CSDataPort : TDXCritical ;
//    feDataSocketOnFilter: TDXFilterCallBack;
    procedure StoreFile(ClientThread: TDXClientThread; FileName: String;
      Append: Boolean);
    function ValidateUser(ClientThread: TDXClientThread; Username, Password : string ) : boolean;
  protected
    { Protected declarations }
    procedure DoDataSocketOnRead( xClientThread:TThread; BytesToRead, Readbytes : integer; var AbortXfer : boolean);
    procedure DoDataSocketOnWrite( xClientThread:TThread; TotalBytes, BytesLeft, BytesSent: integer; var AbortXfer : boolean);
    procedure CalcSpeed( ClientThread: TDXClientThread; BytesXfer : integer );
  public
    { Public declarations }
    constructor Create(AOwner:TComponent); {$IFNDEF OBJECTS_ONLY} override; {$ENDIF}
    destructor Destroy; override;

    procedure CalcNextDataPort  ;
    Function  CheckAuthorized( ClientThread: TDXClientThread; cmd : String ) : boolean  ;
    Procedure DoNewConnect( ClientThread: TDXClientThread);
    procedure DoCommandUSER(ClientThread: TDXClientThread; Username : string );
    procedure DoLog( ClientThread: TDXClientThread; Cmd: string; parm1:string ; parm2: string ='' ;parm3: string ='';parm4: string ='');
    function  DoUserHelloMessage( ClientThread: TDXClientThread;List : TStrings ) : boolean  ;
    function  DoUserByeMessage( ClientThread: TDXClientThread;List : TStrings ) : boolean  ;
    procedure DoCommandRETR(ClientThread: TDXClientThread; FileName: String);
    procedure DoCommandPORT(ClientThread: TDXClientThread; Parm : String);
    procedure DoCommandABOR(ClientThread: TDXClientThread);
    procedure DoCommandAPPE(ClientThread: TDXClientThread;
      FileName: String);
    procedure DoCommandCDUP(ClientThread: TDXClientThread);
    procedure DoCommandCWD(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandDELE(ClientThread: TDXClientThread;
      Filename: String);
    procedure DoCommandLIST(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandMKD(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandNLST(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandNOOP(ClientThread: TDXClientThread);
    procedure DoCommandOther(ClientThread: TDXClientThread; Command,
      Parm: String; var Handled: Boolean);
    procedure DoCommandPASS(ClientThread: TDXClientThread;
      password: String; var SuccessfulLogin: Boolean);
    procedure DoCommandPASV(ClientThread: TDXClientThread);
    procedure DoCommandPWD(ClientThread: TDXClientThread);
    procedure DoCommandQUIT(ClientThread: TDXClientThread);
    procedure DoCommandREIN(ClientThread: TDXClientThread);
    procedure DoCommandREST(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandRMD(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandRNFR(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandRNTO(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandSITE(ClientThread: TDXClientThread; Parm: String);
//    procedure DoCommandSIZE(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandSTAT(ClientThread: TDXClientThread; Parm: String);
    procedure DoCommandSTOR(ClientThread: TDXClientThread;
      FileName: String);
    procedure DoCommandSYST(ClientThread: TDXClientThread);
    procedure DoCommandTYPE(ClientThread: TDXClientThread; Parm: String);
    function  DoInitialGreetingMessage( ClientThread: TDXClientThread;List : TStrings ) : boolean;
  published
    { Published declarations }
    property  NextDataPort : Integer read FNextDataPort ;
    property HomeDirIsRoot : boolean read fHomeDirIsRoot write FhomedirIsRoot ;
    property WorkLikeDos   : boolean  read FWorkLikeDos write fWorkLikeDos;
    property PasvLowDataPort : integer read FPasvLowDataPort write fPasvLowDataPort;   //=5000;
    property PasvMaxDataPort : integer  read FPasvMaxDataPort write fPasvMaxDataPort; // =LowDataPort+1500;
    property DefaultDataPort : integer  read FDefaultDataPort write fDefaultDataPort;
    property OnlyTransferFromSameIP : boolean read fSameIPOnly write fSameIPOnly;
    property NATAddress : string read fNatAddress write fNatAddress;
    property UseNATAddressPASV : Boolean read  fUseNatAddr write fUseNatAddr;
//    property MaxReceiveSpeed : integer  read  write;
//    property MaxSendSpeed : integer  read  write;

    property OnCreateSessionData:  TDX_NewConnect  read feCreateSessionData
         write feCReateSessionData;
    property OnDestroySessionData:TDX_DestroySessionData read feDestroySessionData
         write feDestroySessionData;
    Property OnLogActivity : TLogProc read fLogProc write fLogProc ;
    Property OnDisconnect  : TDX_NewConnect read fDisconnect write fDisconnect;
    Property OnTransferBegin : TDXFTP_FILETRANSFER read fTransferBegin write fTransferBegin;
    Property OnTransferEnd  : TDXFTP_FILETRANSFER   read fTransferEnd write fTransferEnd ;
    property OnTransferRead  : TDXFTP_PROCFILETRANSFER read feDataSocketOnRead write feDataSocketOnRead;
    property OnTransferWrite : TDXFTP_PROCFILETRANSFER read feDataSocketOnWrite write feDataSocketOnWrite;
    property OnUserHelloMessage :  TDXFTP_CLNTLST read fuserHello write fuserHello;
    property OnUserByeMessage :  TDXFTP_CLNTLST  read fuserBye write fuserBye;
    property OnInitialGreeting :  TDXFTP_CLNTLST  read fInitGreet write fInitGreet;
    property OnValidateUser :  TDXFTP_VALIDUSR  read fValidateUser write fValidateUser;
    property OnAfterValidateUser :  TDXFTP_VALIDUSR  read fAfterValidUser write fAfterValidUser;
//    property OnDataSocketFilter: TDXFilterCallBack read feDataSocketOnFilter  write feDataSocketOnFilter;
  end;

procedure Register;

implementation

{------------------------------------------------------------------------------}
procedure Register;
begin
  RegisterComponents('BPDX Popular Servers', [TDXFTPBaseServer]);
end;

{ TDXFTPBaseServer }
{------------------------------------------------------------------------------}
constructor TDXFTPBaseServer.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FWorkLikeDos:= False;
   fHomeDirIsRoot:=True;
   FPasvLowDataPort:= 5000;
   FPasvMaxDataPort:= FPasvLowDataPort + 2500;
   FDefaultDataPort:= 20 ;
   FNextDataPort:= FPasvLowDataPort ;
   CSDataPort := TDXCritical.Create; ;
end;

{------------------------------------------------------------------------------}
destructor TDXFTPBaseServer.Destroy;
begin
  CSDataPort.Free ;

  inherited Destroy;
end;
{------------------------------------------------------------------------------}
Procedure TDXFTPBaseServer.CalcNextDataPort ;
begin
 CSDataPort.StartingWrite ;
 try
   InterlockedIncrement( fNextDataPort );
   if fNextDataPort > FPasvMaxDataPort then
      fNextDataPort := FPasvLowDataPort ;
 finally
   CSDataPort.FinishedWrite;
 end;

end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoLog( ClientThread: TDXClientThread;Cmd : string ;  parm1: string ; parm2: string;parm3: string;parm4: string);
//    procedure DoLog( ClientThread: TDXClientThread; Cmd: string; parm1:string ; parm2: string ='' ;parm3: string ='';parm4: string ='');
begin
  if Assigned( fLogProc ) then
     fLogProc( ClientThread ,Cmd,parm1,parm2,parm3,parm4);
end;
{------------------------------------------------------------------------------}
Function  TDXFTPBaseServer.CheckAuthorized( ClientThread: TDXClientThread; cmd : String ) : boolean  ;
begin
   if not PUserSession(ClientThread.fpSessionData)^.AuthorizedState then begin
      ClientThread.Socket.WriteLn(ErrorText(530));
      DoLog( ClientThread, Cmd , 'NOT AUTHORIZED');
      result := False ;
   end
   else
      result := true ;
end;
{------------------------------------------------------------------------------}
Function  TDXFTPBaseServer.DoUserHelloMessage( ClientThread: TDXClientThread;List : TStrings ) : boolean  ;
begin
   if Assigned( fUserHello ) then
     result := FUserHello( ClientThread , List )
   else
     result := false ;
end;
{------------------------------------------------------------------------------}
Function  TDXFTPBaseServer.DoUserByeMessage( ClientThread: TDXClientThread;List : TStrings ) : boolean  ;
begin
   if Assigned( fUserBye ) then
     result := FUserBye( ClientThread , List )
   else
     result := false ;
end;
{------------------------------------------------------------------------------}
function  TDXFTPBaseServer.DoInitialGreetingMessage( ClientThread: TDXClientThread;List : TStrings ) : boolean;
begin
   if Assigned( fInitGreet ) then
     result := fInitGreet( ClientThread , List )
   else
     result := false ;
end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoCommandUSER(ClientThread: TDXClientThread; Username : string );
begin
   if not PUserSession(ClientThread.fpSessionData)^.AuthorizedState  then begin
     DoLog(  ClientThread, 'User',UserName );

     PUserSession(ClientThread.fpSessionData)^.User:=UserName;

     ClientThread.Socket.Writeln('331 Password required for '+Username+'.');
   end
   else begin
     ClientThread.Socket.Writeln('550 Disconnect First');
   end;
end;
{------------------------------------------------------------------------------}
procedure TDXFTPBaseServer.DoNewConnect(ClientThread: TDXClientThread);
Var
   UserRec:PUserSession;
   Header:TStringList;
begin
try

// Move into Session Create data
   New(UserRec);
   ZeroMemory(UserRec,Sizeof(UserRec^)); // Clear all fields
   With UserRec^ do Begin
      AuthorizedState:=false;
      PASV:=False;
      PeerIPAddress:=ClientThread.Socket.PeerIPAddress;
      NewConnect:=TDXNewConnect.Create;
      NewConnect.UseNAGLE:=True;
      NewConnect.UseUDP:=False;
      NewConnect.UseBLOCKING:=False;
      NewConnect.Port:=fDefaultDataPort;
      DataSocket:=TDXSock.Create(Nil); // Ozz PASV
//05-01-12 -<
      DataSocket.OnWriteBuffer := DoDataSocketOnWrite;
      DataSocket.OnReadBuffer  := DoDataSocketOnRead;
      if DataSocket.TLSClientThread = NIL then
           DataSocket.TLSClientThread := ClientThread ;
//05-01-12  >-
      UserData := nil ;  // GetNewDataMosule( ClientThread )
   End;

   ClientThread.fpSessionData:=UserRec;

   if Assigned( feCReateSessionData ) then
      feCReateSessionData( ClientThread ) ;

   // User Clean up procedures
   ClientThread.OnDestroySessionData := OnDestroySessionData ;

   Header:=TStringList.Create;

   Header.Clear;
   DoInitialGreetingMessage( ClientThread , Header );
   SayHello(ClientThread, Header );

   Header.Clear ;
   DoUserHelloMessage( ClientThread , Header );
   ProcessSession(ClientThread, Header );