mainform.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 925 行 · 第 1/2 页

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SBSSHConstants, SBSSHClient, SBSSHCommon, SBSftp, SBSftpCommon,
  SBSSHKeyStorage, SBUtils,
  StdCtrls, Grids, ScktComp, Buttons;

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    editHost: TEdit;
    Label1: TLabel;
    editUserName: TEdit;
    Label2: TLabel;
    Label3: TLabel;
    editPassword: TEdit;
    StringGrid1: TStringGrid;
    scktClient: TClientSocket;
    Memo1: TMemo;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    SaveDialog1: TSaveDialog;
    OpenDialog1: TOpenDialog;
    Edit4: TEdit;
    EditPath: TEdit;
    btnUpdateFileInfo: TButton;
    GroupBox2: TGroupBox;
    CheckBoxV3: TCheckBox;
    CheckBoxV4: TCheckBox;
    CheckBoxV2: TCheckBox;
    btnConnect: TButton;
    lbPrivateKey: TLabel;
    edPrivateKey: TEdit;
    sbPrivateKey: TSpeedButton;
    OpenDialog: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure scktClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure scktClientRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure btnConnectClick(Sender: TObject);
    procedure StringGrid1DblClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure scktClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure btnUpdateFileInfoClick(Sender: TObject);
    procedure sbPrivateKeyClick(Sender: TObject);
  private
    procedure HandleSSHClientSend(Sender : TObject; Buffer : pointer; Size : integer);
    procedure HandleSSHClientReceive(Sender : TObject; Buffer : pointer; MaxSize : integer;
      out Written : integer);
    procedure HandleSSHClientOpenConnection(Sender : TObject);
    procedure HandleSSHClientCloseConnection(Sender : TObject);
    procedure HandleSSHClientAuthSuccess(Sender : TObject);
    procedure HandleSSHClientAuthFailed(Sender : TObject; AuthType : integer);
    procedure HandleClientAuthenticationKeyboard(Sender: TObject;
     Prompts : TStringList; Echo : TBits; Responses : TStringList);

    procedure HandleSSHClientKeyValidate(Sender: TObject; ServerKey: TElSSHKey; var Validate: Boolean);
    procedure HandleSftpOpenConnection(Sender : TObject);
    procedure HandleSftpCloseConnection(Sender : TObject);
    procedure HandleSftpOpenFile(Sender : TObject; Handle : TSBSftpFileHandle);
    procedure HandleSftpError(Sender : TObject; ErrorCode : integer; const Comment : string);
    procedure HandleSftpSuccess(Sender : TObject; const Comment : string);
    procedure HandleSftpDirectoryListing(Sender : TObject; Listing :
      array of TElSftpFileInfo);
    procedure HandleSftpData(Sender : TObject; Buffer : pointer; Size : integer);
    procedure HandleSftpAbsolutePath(Sender : TObject; const Path : string);
    procedure HandleSftpFileAttributes(Sender: TObject; Attributes: 
        TElSftpFileAttributes);
    procedure ClearFileList;
  public
    function AbsPath(FileName : string) : string;
    procedure CloseCurrentHandle;

    procedure Log(S : string);
    procedure BuildFileList(Path : string);
    procedure OutputFileList;
    procedure ChangeDir(Dir : string);
    procedure MakeDir(Dir : string);
    procedure RenameFile(OldName, NewName : string);
    procedure DeleteDir(Name : string);
    procedure DeleteFile(Name : string);
    procedure DownloadFile(Info : TElSftpFileInfo; LocalName : string);
    procedure UploadFile(LocalFile : string);
    procedure WriteNextBlockToFile;
    function WritePermissions(Attributes : TElSftpFileAttributes) : string;
    function FormatPath(Path : string) : string;
    procedure RequestAbsolutePath(Path : string);
    procedure SetCellInfo(Index : integer; Info : TElSftpFileInfo);
  end;

var
  Form1: TForm1;
  SSHClient : TElSSHClient;
  TunnelList : TElSSHTunnelList;
  SftpTunnel : TElSubsystemSSHTunnel;
  SftpClient : TElSftpClient;
  KeyStorage: TElSSHMemoryKeyStorage;
  State : integer;
  CurrentHandle : TSBSftpFileHandle;
  CurrentFileList : TList;
  CurrentDir : string;
  RelDir : string;
  CurrentFileOffset : cardinal;
  CurrentFileSize : cardinal;
  CurrentFile : file;

const
  FILE_BLOCK_SIZE               = $10000;
  STATE_OPEN_DIRECTORY_SENT     = 1;
  STATE_READ_DIRECTORY_SENT     = 2;
  STATE_CHANGE_DIR              = 3;
  STATE_MAKE_DIR                = 4;
  STATE_RENAME                  = 5;
  STATE_REMOVE                  = 6;
  STATE_DOWNLOAD_OPEN           = 7;
  STATE_DOWNLOAD_RECEIVE        = 8;
  STATE_UPLOAD_OPEN             = 9;
  STATE_UPLOAD_SEND             = 10;
  STATE_CLOSE_HANDLE            = 11;

implementation

uses ProgressForm, PromptForm;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  SSHClient := TElSSHClient.Create(Self);
  SSHClient.Versions := [sbSSH2];
  SSHClient.OnSend := HandleSSHClientSend;
  SSHClient.OnReceive := HandleSSHClientReceive;
  SSHClient.OnOpenConnection := HandleSSHClientOpenConnection;
  SSHClient.OnCloseConnection := HandleSSHClientCloseConnection;
  SSHClient.OnAuthenticationSuccess := HandleSSHClientAuthSuccess;
  SSHClient.OnAuthenticationFailed := HandleSSHClientAuthFailed;
  SSHClient.OnAuthenticationKeyboard := HandleClientAuthenticationKeyboard;

  SSHClient.OnKeyValidate := HandleSSHClientKeyValidate;
  TunnelList := TElSSHTunnelList.Create(Self);
  SftpTunnel := TElSubsystemSSHTunnel.Create(Self);
  SftpClient := TElSftpClient.Create(Self);
  SftpTunnel.TunnelList := TunnelList;
  SSHClient.TunnelList := TunnelList;
  SftpClient.Tunnel := SftpTunnel;
  SftpClient.OnOpenConnection := HandleSftpOpenConnection;
  SftpClient.OnCloseConnection := HandleSftpCloseConnection;
  SftpClient.OnOpenFile := HandleSftpOpenFile;
  SftpClient.OnError := HandleSftpError;
  SftpClient.OnSuccess := HandleSftpSuccess;
  SftpClient.OnDirectoryListing := HandleSftpDirectoryListing;
  SftpClient.OnData := HandleSftpData;
  SftpClient.OnAbsolutePath := HandleSftpAbsolutePath;
  SftpClient.OnFileAttributes := HandleSftpFileAttributes;

  KeyStorage := TElSSHMemoryKeyStorage.Create(Self);
  SSHClient.KeyStorage := KeyStorage;

  CurrentFileList := TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  KeyStorage.Free;
  SSHClient.Free;
  TunnelList.Free;
  SftpTunnel.Free;
  SftpClient.Free;
  ClearFileList;
  CurrentFileList.Free;
end;

procedure TForm1.Log(S : string);
begin
  Memo1.Lines.Add(DateTimeToStr(Now) + ' ' + S);
end;

////////////////////////////////////////////////////////////////////////////////
// Handlers

procedure TForm1.HandleSSHClientSend(Sender : TObject; Buffer : pointer; Size : integer);
begin
  while scktClient.Socket.SendBuf(Buffer^, Size) = -1 do
    Sleep(50);
end;

procedure TForm1.HandleSSHClientReceive(Sender : TObject; Buffer : pointer; MaxSize : integer;
  out Written : integer);
begin
  Written := scktClient.Socket.ReceiveBuf(Buffer^, MaxSize);
  if Written < 0 then
    Written := 0;
end;

procedure TForm1.HandleSSHClientOpenConnection(Sender : TObject);
begin
  Log('SSH Connection started with ' + SSHClient.ServerSoftwareName);
end;

procedure TForm1.HandleSSHClientCloseConnection(Sender : TObject);
begin
  Log('SSH Connection closed');
end;

procedure TForm1.HandleSSHClientAuthSuccess(Sender : TObject);
begin
  Log('Authentication succeeded');
end;

procedure TForm1.HandleSSHClientAuthFailed(Sender : TObject; AuthType : integer);
begin
  Log('Authentication failed. Unknown user or Invalid password.');
end;

procedure TForm1.HandleSftpOpenConnection(Sender : TObject);
var
  S : string;
begin
  Log('Sftp connection started');
  if SftpClient.Version = sbSFTP1 then
    S := '1'
  else
  if SftpClient.Version = sbSFTP2 then
    S := '2'
  else
  if SftpClient.Version = sbSFTP3 then
    S := '3'
  else 
  if SftpClient.Version = sbSFTP4 then
    S := '4'
  else
    S := 'unknown';
  Log('Sftp version is ' + S);
  CurrentDir := '.';
  BuildFileList('.');
end;

procedure TForm1.HandleSftpCloseConnection(Sender : TObject);
begin
  Log('Sftp connection closed');
end;

procedure TForm1.HandleSftpOpenFile(Sender : TObject; Handle : TSBSftpFileHandle);
begin
  if State = STATE_OPEN_DIRECTORY_SENT then
  begin
    Log('Directory opened');
    CurrentHandle := Handle;
    SftpClient.ReadDirectory(CurrentHandle);
    State := STATE_READ_DIRECTORY_SENT;
  end
  else if State = STATE_CHANGE_DIR then
  begin
    SftpClient.CloseHandle(Handle);
  end
  else 
  if State = STATE_DOWNLOAD_OPEN then
  begin
    CurrentHandle := Handle;
    Form2.Gauge1.Progress := 0;
    Form2.Show;
    SftpClient.Read(Handle, CurrentFileOffset, FILE_BLOCK_SIZE);
    State := STATE_DOWNLOAD_RECEIVE;
  end
  else if State = STATE_UPLOAD_OPEN then
  begin
    CurrentHandle := Handle;
    Form2.Gauge1.Progress := 0;
    Form2.Show;
    WriteNextBlockToFile;
    State := STATE_UPLOAD_SEND;
  end;
end;

procedure TForm1.HandleSftpError(Sender : TObject; ErrorCode : integer;
  const Comment : string);
begin
  if (State = STATE_READ_DIRECTORY_SENT) and (ErrorCode = SSH_ERROR_EOF) then
  begin
    Log('File list received');
    CloseCurrentHandle;
    OutputFileList;
  end
  else
  if (State = STATE_DOWNLOAD_RECEIVE) and (ErrorCode = SSH_ERROR_EOF) then
  begin
    Log('File received');
    CloseFile(CurrentFile);
    CloseCurrentHandle;
  end
  else
    Log('Error #' + IntToStr(ErrorCode) + ' with comment "' + Comment + '"')  
end;

procedure TForm1.HandleSftpSuccess(Sender : TObject; const Comment : string);
begin
  if State = STATE_CHANGE_DIR then
  begin
    Log('Operation succeeded with comment "' + Comment + '"');
    RequestAbsolutePath(AbsPath(RelDir) + '/');
  end
  else 
  if (State = STATE_MAKE_DIR) or (State = STATE_RENAME) or
    (State = STATE_REMOVE) then
  begin
    Log('Operation succeeded with comment "' + Comment + '"');
    BuildFileList(CurrentDir);
  end
  else if (State = STATE_UPLOAD_SEND) then
  begin
    Form2.Gauge1.Progress := 100 * CurrentFileOffset div CurrentFileSize;
    WriteNextBlockToFile;
  end
  else if (State = STATE_CLOSE_HANDLE) then
  begin
    CloseFile(CurrentFile);
    BuildFileList(CurrentDir);
  end;
end;

procedure TForm1.HandleSftpDirectoryListing(Sender : TObject; Listing :
  array of TElSftpFileInfo);
var
  I : integer;
  FileInfo : TElSftpFileInfo;
begin
  if State = STATE_READ_DIRECTORY_SENT then
  begin
    for I := 0 to Length(Listing) - 1 do
    begin
      FileInfo := TElSftpFileInfo.Create;
      Listing[I].CopyTo(FileInfo);
      CurrentFileList.Add(FileInfo);
    end;
    SftpClient.ReadDirectory(CurrentHandle);
  end;
end;

procedure TForm1.HandleSftpData(Sender : TObject; Buffer : pointer; Size : integer);
begin
  if State = STATE_DOWNLOAD_RECEIVE then
  begin
    BlockWrite(CurrentFile, Buffer^, Size);
    Inc(CurrentFileOffset, Size);
    if CurrentFileOffset >= CurrentFileSize then
    begin
      Form2.Close;
      Log('File received');
      CloseFile(CurrentFile);
      CloseCurrentHandle;
    end
    else
    begin
      SftpClient.Read(CurrentHandle, CurrentFileOffset, FILE_BLOCK_SIZE);
      Form2.Gauge1.Progress := 100 * CurrentFileOffset div CurrentFileSize;
    end;
  end;
end;

procedure TForm1.HandleSftpAbsolutePath(Sender : TObject; const Path : string);
begin
  CurrentDir := Path;
  BuildFileList(CurrentDir);
  EditPath.Text := Path;
end;

procedure TForm1.scktClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
var
  Key: TElSSHKey;
begin
  Log('TCP connection opened');
  SSHClient.EncryptionAlgorithms[SSH_EA_3DES] := false;
  SSHClient.EncryptionAlgorithms[SSH_EA_DES] := false;
  SSHClient.EncryptionAlgorithms[SSH_EA_BLOWFISH] := false;

  SSHClient.UserName := editUsername.Text;
  SSHClient.Password := editPassword.Text;

  KeyStorage.Clear;
  Key := TElSSHKey.Create;
  if (edPrivateKey.Text <> '') and FileExists(edPrivateKey.Text) and
     (Key.LoadPrivateKey(edPrivateKey.Text) = 0) then
  begin
    KeyStorage.Add(Key);
    SSHClient.AuthenticationTypes := SSHClient.AuthenticationTypes or SSH_AUTH_TYPE_PUBLICKEY;
  end
  else
    SSHClient.AuthenticationTypes := SSHClient.AuthenticationTypes and not SSH_AUTH_TYPE_PUBLICKEY;

  Key.Free;

  SSHClient.Open;
end;

procedure TForm1.scktClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  SSHClient.DataAvailable;
end;

procedure TForm1.btnConnectClick(Sender: TObject);
begin
  if scktClient.Active then
  begin
    scktClient.Close;
    btnConnect.Caption := 'Connect';
  end
  else
  begin
    SftpClient.Versions := [];
    if CheckBoxV2.Checked then
      SftpClient.Versions := SftpClient.Versions + [sbSFTP2];
    if CheckBoxV3.Checked then
      SftpClient.Versions := SftpClient.Versions + [sbSFTP3];
    if CheckBoxV4.Checked then
      SftpClient.Versions := SftpClient.Versions + [sbSFTP4];
    btnConnect.Caption := 'Disconnect';

    if Pos(':', editHost.Text) > 0 then
    begin
      scktClient.Host := Copy(editHost.Text, 1, Pos(':', editHost.Text) - 1);
      scktClient.Port := StrToIntDef(Copy(editHost.Text, Pos(':', editHost.Text) + 1, Length(editHost.Text)), 22);
    end
    else
    begin
      scktClient.Host := editHost.Text;
      scktClient.Port := 22;
    end;

    scktClient.Open;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
// Interface routines

procedure TForm1.BuildFileList(Path : string);
begin
  if not scktClient.Active then
  begin
    Log('Error: not connected');
    Exit;
  end;
  ClearFileList;
  Log('Opening directory ' + Path);
  SftpClient.OpenDirectory(Path);
  State := STATE_OPEN_DIRECTORY_SENT;
end;