{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10167: IdFTPServer.pas 
{
{   Rev 1.6    7/13/04 7:03:30 PM  RLebeau
{ Readded DataPort property to TIdFTPServerThread and made read-only
}
{
{   Rev 1.5    7/13/04 5:42:06 PM  RLebeau
{ Various changes to hook up the DefaultDataPort property correctly
}
{
{   Rev 1.4    2/17/04 4:40:50 PM  RLebeau
{ OnPASV event added for people needing to change the IP address or port value
{ in the PASV command.  This should only be done if you have a compelling
{ reason to do it.
}
{
    Rev 1.3    1/23/2003 9:09:18 PM  BGooijen
  Changed ABOR to fix the command while uploading
}
{
{   Rev 1.2    1-9-2003 11:44:42  BGooijen
{ Added ABOR command with telnet escape characters
{ Fixed hanging of ABOR command
{ STOR and STOU now use REST-position
}
{
{   Rev 1.1    12/10/2002 07:43:04 AM  JPMugaas
{ Merged fix for a problem were resume cause the entire file to be sent instead
{ of the part requrested.
}
{
{   Rev 1.0    2002.11.12 10:39:06 PM  czhower
}
unit IdFTPServer;
{
 Original Author: Sergio Perry
 Date: 04/21/2001

 Fixes and modifications: Doychin Bondzhev
 Date: 08/10/2001

 Further Extensive changes by Chad Z. Hower (Kudzu)

TODO:
 - Change events to use DoXXXX
}

interface

uses
  Classes,
  SysUtils,  IdAssignedNumbers,
  IdException, IdFTPList, IdTCPServer, IdTCPConnection, IdUserAccounts,
  IdFTPCommon, IdThread, IdRFCReply;

type
  TIdFTPUserType = (utNone, utAnonymousUser, utNormalUser);
  TIdFTPSystems = (ftpsOther, ftpsDOS, ftpsUNIX, ftpsVAX);
  TIdFTPOperation = (ftpRetr, ftpStor);

const
  Id_DEF_AllowAnon  = False;
  Id_DEF_PassStrictCheck = True;
  Id_DEF_SystemType = ftpsDOS;

type
  TIdFTPServerThread = class;

  TOnUserLoginEvent = procedure(ASender: TIdFTPServerThread; const AUsername, APassword: string;
    var AAuthenticated: Boolean) of object;
  TOnAfterUserLoginEvent = procedure(ASender: TIdFTPServerThread) of object;
  TOnDirectoryEvent = procedure(ASender: TIdFTPServerThread; var VDirectory: string) of object;
  TOnGetFileSizeEvent = procedure(ASender: TIdFTPServerThread; const AFilename: string;
    var VFileSize: Int64) of object;
  TOnListDirectoryEvent = procedure(ASender: TIdFTPServerThread; const APath: string;
    ADirectoryListing: TIdFTPListItems) of object;
  TOnFileEvent = procedure(ASender: TIdFTPServerThread; const APathName: string) of object;
  TOnRenameFileEvent = procedure(ASender: TIdFTPServerThread; const ARenameFromFile,ARenameToFile: string) of object;
  TOnRetrieveFileEvent = procedure(ASender: TIdFTPServerThread; const AFileName: string;
    var VStream: TStream) of object;
  TOnStoreFileEvent = procedure(ASender: TIdFTPServerThread; const AFileName: string;
    AAppend: Boolean; var VStream: TStream) of object;
  //This is for PASV support - do not change the values unless you
  //have an extremely compelling reason to do so.  This even is ONLY for those compelling case.
  TOnPASVEvent = procedure(ASender: TIdFTPServerThread; var VIP : String; var VPort : Word) of object;

  EIdFTPServerException = class(EIdException);
  EIdFTPServerNoOnListDirectory = class(EIdFTPServerException);

  TIdDataChannelThread = class(TIdThread)
  protected
    FControlChannel: TIdTCPServerConnection;
    FDataChannel: TIdTCPConnection;
    FErrorReply: TIdRFCReply;
    FFtpOperation: TIdFTPOperation;
    FOKReply: TIdRFCReply;
    //
    procedure Run; override;
    procedure SetErrorReply(const AValue: TIdRFCReply);
    procedure SetOKReply(const AValue: TIdRFCReply);
  public
    constructor Create(APASV: Boolean; AControlConnection: TIdTCPServerConnection); reintroduce;
    destructor Destroy; override;
    procedure StartThread(AOperation: TIdFTPOperation);
    procedure SetupDataChannel(const AIP: string; APort: Integer);
    //
    property OKReply: TIdRFCReply read FOKReply write SetOKReply;
    property ErrorReply: TIdRFCReply read FErrorReply write SetErrorReply;
  end;

  TIdFTPServerThread = class(TIdPeerThread)
  protected
    FUserType: TIdFTPUserType;
    FAuthenticated: Boolean;
    FALLOSize: Integer;
    FCurrentDir: string;
    FDataType: TIdFTPTransferType;
    FDataMode: TIdFTPTransferMode;
    FDataPort: Integer;
    FDataStruct: TIdFTPDataStructure;
    FDataChannelThread: TIdDataChannelThread;
    FHomeDir: string;
    FUsername: string;
    FPassword: string;
    FPASV: Boolean;
    FRESTPos: Integer;
    FRNFR: string;
    //
    procedure CreateDataChannel(APASV: Boolean = False);
    function  IsAuthenticated(ASender: TIdCommand): Boolean;
    procedure KillDataChannel;
    procedure TerminateAndFreeDataChannel;
    procedure ReInitialize;
  public
    constructor Create(ACreateSuspended: Boolean = True); override;
    destructor Destroy; override;
    //
    property Authenticated: Boolean read FAuthenticated write FAuthenticated;
    property ALLOSize: Integer read FALLOSize write FALLOSize;
    property CurrentDir: string read FCurrentDir write FCurrentDir;
    property DataChannelThread: TIdDataChannelThread read FDataChannelThread
     write FDataChannelThread;
    property DataType: TIdFTPTransferType read FDataType write FDataType;
    property DataMode: TIdFTPTransferMode read FDataMode write FDataMode;
    property DataPort: Integer read FDataPort;
    property DataStruct: TIdFTPDataStructure read FDataStruct write FDataStruct;
    property HomeDir: string read FHomeDir write FHomeDir;
    property Password: string read FPassword write FPassword;
    property PASV: Boolean read FPASV write FPASV;
    property RESTPos: Integer read FRESTPos write FRESTPos;
    property Username: string read FUsername write FUsername;
    property UserType: TIdFTPUserType read FUserType write FUserType;
  end;

  TIdFTPServer = class;

  TIdOnGetCustomListFormat = procedure(ASender: TIdFTPServer; AItem: TIdFTPListItem;
   var VText: string) of object;

  { FTP Server }
  TIdFTPServer = class(TIdTCPServer)
  protected
    FAnonymousAccounts: TstringList;
    FAllowAnonymousLogin: Boolean;
    FAnonymousPassStrictCheck: Boolean;
    FCmdHandlerList: TIdCommandHandler;
    FCmdHandlerNlst: TIdCommandHandler;
    FEmulateSystem: TIdFTPSystems;
    FHelpReply: Tstrings;
    FSystemType: string;
    FDefaultDataPort : Integer;
    FUserAccounts: TIdUserManager;
    FOnAfterUserLogin: TOnAfterUserLoginEvent;
    FOnGetCustomListFormat: TIdOnGetCustomListFormat;
    FOnUserLogin: TOnUserLoginEvent;
    FOnChangeDirectory: TOnDirectoryEvent;
    FOnGetFileSize: TOnGetFileSizeEvent;
    FOnListDirectory: TOnListDirectoryEvent;
    FOnRenameFile: TOnRenameFileEvent;
    FOnDeleteFile: TOnFileEvent;
    FOnRetrieveFile: TOnRetrieveFileEvent;
    FOnStoreFile: TOnStoreFileEvent;
    FOnMakeDirectory: TOnDirectoryEvent;
    FOnRemoveDirectory: TOnDirectoryEvent;
    FOnPASV : TOnPASVEvent;
    //Command replies
    procedure CommandUSER(ASender: TIdCommand);
    procedure CommandPASS(ASender: TIdCommand);
    procedure CommandCWD(ASender: TIdCommand);
    procedure CommandCDUP(ASender: TIdCommand);
    procedure CommandREIN(ASender: TIdCommand);
    procedure CommandPORT(ASender: TIdCommand);
    procedure CommandPASV(ASender: TIdCommand);
    procedure CommandTYPE(ASender: TIdCommand);
    procedure CommandSTRU(ASender: TIdCommand);
    procedure CommandMODE(ASender: TIdCommand);
    procedure CommandRETR(ASender: TIdCommand);
    procedure CommandSSAP(ASender: TIdCommand);
    procedure CommandALLO(ASender: TIdCommand);
    procedure CommandREST(ASender: TIdCommand);
    procedure CommandRNFR(ASender: TIdCommand);
    procedure CommandRNTO(ASender: TIdCommand);
    procedure CommandABOR(ASender: TIdCommand);
    procedure CommandDELE(ASender: TIdCommand);
    procedure CommandRMD(ASender: TIdCommand);
    procedure CommandMKD(ASender: TIdCommand);
    procedure CommandPWD(ASender: TIdCommand);
    procedure CommandLIST(ASender: TIdCommand);
    procedure CommandSITE(ASender: TIdCommand);
    procedure CommandSYST(ASender: TIdCommand);
    procedure CommandSTAT(ASender: TIdCommand);
    procedure CommandSIZE(ASender: TIdCommand);
    procedure CommandFEAT(ASender: TIdCommand);
    procedure CommandOPTS(ASender: TIdCommand);
    //
    procedure DoChangeDirectory(AThread: TIdFTPServerThread; var VDirectory: string);
    procedure DoMakeDirectory(AThread: TIdFTPServerThread; var VDirectory: string);
    procedure DoRemoveDirectory(AThread: TIdFTPServerThread; var VDirectory: string);
    procedure DoGetCustomListFormat(AItem: TIdFTPListItem; var VText: string);
    procedure DoOnPASV(AThread: TIdFTPServerThread; var VIP: String; var VPort: Word);
    procedure InitializeCommandHandlers; override;
    procedure ListDirectory(ASender: TIdFTPServerThread; ADirectory: string;
      var ADirContents: TstringList; ADetails: Boolean);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetAnonymousAccounts(const AValue: TstringList);
    procedure SetHelpReply(const AValue: Tstrings);
    procedure SetUserAccounts(const AValue: TIdUserManager);
    procedure SetEmulateSystem(const AValue: TIdFTPSystems);
    procedure ThreadException(AThread: TIdThread; AException: Exception);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property AllowAnonymousLogin: Boolean read FAllowAnonymousLogin write FAllowAnonymousLogin default Id_DEF_AllowAnon;
    property AnonymousAccounts: TStringList read FAnonymousAccounts write SetAnonymousAccounts;
    property AnonymousPassStrictCheck: Boolean read FAnonymousPassStrictCheck
     write FAnonymousPassStrictCheck default Id_DEF_PassStrictCheck;
    property DefaultDataPort : Integer read FDefaultDataPort write FDefaultDataPort default IdPORT_FTP_DATA;
    property EmulateSystem: TIdFTPSystems read FEmulateSystem write SetEmulateSystem default Id_DEF_SystemType;
    property HelpReply: Tstrings read FHelpReply write SetHelpReply;
    property UserAccounts: TIdUserManager read FUserAccounts write SetUserAccounts;
    property SystemType: string read FSystemType write FSystemType;
    property OnAfterUserLogin: TOnAfterUserLoginEvent read FOnAfterUserLogin
     write FOnAfterUserLogin;
    property OnChangeDirectory: TOnDirectoryEvent read FOnChangeDirectory write FOnChangeDirectory;
    property OnGetCustomListFormat: TIdOnGetCustomListFormat read FOnGetCustomListFormat
     write FOnGetCustomListFormat;
    property OnGetFileSize: TOnGetFileSizeEvent read FOnGetFileSize write FOnGetFileSize;
    property OnUserLogin: TOnUserLoginEvent read FOnUserLogin write FOnUserLogin;
    property OnListDirectory: TOnListDirectoryEvent read FOnListDirectory write FOnListDirectory;
    property OnRenameFile: TOnRenameFileEvent read FOnRenameFile write FOnRenameFile;
    property OnDeleteFile: TOnFileEvent read FOnDeleteFile write FOnDeleteFile;
    property OnRetrieveFile: TOnRetrieveFileEvent read FOnRetrieveFile write FOnRetrieveFile;
    property OnStoreFile: TOnStoreFileEvent read FOnStoreFile write FOnStoreFile;
    property OnMakeDirectory: TOnDirectoryEvent read FOnMakeDirectory write FOnMakeDirectory;
    property OnRemoveDirectory: TOnDirectoryEvent read FOnRemoveDirectory write FOnRemoveDirectory;
    {
    READ THIS!!!

    Do not change values in the OnPASV event unless you have a compelling reason to do so.
    }
    property OnPASV : TOnPASVEvent read FOnPASV write FOnPASV;
  end;

implementation

uses
  IdGlobal,
  IdIOHandlerSocket,
  IdResourcestrings,
  IdSimpleServer,
  IdSocketHandle,
  Idstrings,
  IdTCPClient,
  IdEMailAddress;

{ TIdDataChannelThread }

constructor TIdDataChannelThread.Create(APASV: Boolean; AControlConnection: TIdTCPServerConnection);
begin
  inherited Create;
  StopMode := smSuspend;
  FOKReply := TIdRFCReply.Create(nil);
  FErrorReply := TIdRFCReply.Create(nil);
  FControlChannel := AControlConnection;
  if APASV then begin
    FDataChannel := TIdSimpleServer.Create(nil);
    TIdSimpleServer(FDataChannel).BoundIP := TIdIOHandlerSocket(FControlChannel.IOHandler).Binding.IP;
  end else begin
    FDataChannel := TIdTCPClient.Create(nil);
    TIdTCPClient(FDataChannel).BoundPort := TIdFTPServer(FControlChannel.Server).DefaultDataPort;  //Default dataport
  end;
end;

destructor TIdDataChannelThread.Destroy;
begin
  FreeAndNil(FOKReply);
  FreeAndNil(FErrorReply);
  FreeAndNil(FDataChannel);
  inherited Destroy;
end;

procedure TIdDataChannelThread.StartThread(AOperation: TIdFTPOperation);
begin
  FFtpOperation := AOperation; try
    if FDataChannel is TIdSimpleServer then begin
      TIdSimpleServer(FDataChannel).Listen;
    end else if FDataChannel is TIdTCPClient then begin
      TIdTCPClient(FDataChannel).Connect;
    end;
  except
    FControlChannel.WriteRFCReply(FErrorReply); //426
    raise;
  end;
  inherited Start;
end;

procedure TIdDataChannelThread.Run;
var
  LStrStream: TMemoryStream; //is faster than StringStream
begin
  try
    try
      try
        try
          if Data is TStream then begin
            case FFtpOperation of
              ftpRetr: FDataChannel.WriteStream(TStream(Data),False);
              ftpStor: FDataChannel.ReadStream(TStream(Data), -1, True);
            end;
          end else begin
            case FFtpOperation of
              ftpRetr: FDataChannel.Writestrings(Data as Tstrings);
              ftpStor:
                begin
                  LStrStream := TMemoryStream.Create;
                  try
                    FDataChannel.ReadStream(LStrStream, -1, True);
                    SplitLines(LStrStream.Memory, LStrStream.Size,TStrings(Data));
                  finally
                    FreeAndNil(LStrStream);
                  end;
                end;//ftpStor
            end;//case
          end;
        finally
          FreeAndNIL(FData);
        end;
      finally
        FDataChannel.Disconnect;
      end;
      FControlChannel.WriteRFCReply(FOKReply); //226
    except
      FControlChannel.WriteRFCReply(FErrorReply); //426
    end;
  finally Stop; end;
end;

procedure TIdDataChannelThread.SetupDataChannel(const AIP: string; APort: Integer);
begin
  if FDataChannel is TIdSimpleServer then begin
    with TIdSimpleServer(FDataChannel) do begin
      BoundIP := AIP;
      BoundPort := APort;
    end;
  end else begin
    with TIdTCPClient(FDataChannel) do begin
      Host := AIP;
      Port := APort;
    end;
  end;
end;

procedure TIdDataChannelThread.SetErrorReply(const AValue: TIdRFCReply);
begin
  FErrorReply.Assign(AValue);
end;

procedure TIdDataChannelThread.SetOKReply(const AValue: TIdRFCReply);