mainform.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 334 行

unit MainForm;

interface

uses
  Windows, Messages, Graphics, Controls, Forms, Dialogs, ToolWin, ComCtrls,
  Menus, Buttons, Spin, SysUtils, Classes, IdBaseComponent,
  IdComponent, IdTCPConnection, IdTCPClient, ExtCtrls, StdCtrls,
  IdIOHandler, IdIOHandlerSocket, SBSSHCommon, SBSSHClient,
  Login, SBSSHConstants, SBSSHKeyStorage, SBUtils, SBIndySSHClientIOHandler9;

type
  TfrmChatClient = class(TForm)
    lServer: TLabel;
    edServer: TEdit;
    lOnline: TLabel;
    lbClients: TListBox;
    lMessages: TLabel;
    memMessages: TMemo;
    lYourMessage: TLabel;
    edMessage: TEdit;
    btnConnect: TSpeedButton;
    tmrRefresh: TTimer;
    lPort: TLabel;
    sePort: TSpinEdit;
    btnRefresh: TButton;
    dlgCert: TOpenDialog;
    SSHTransport: TElClientIndySSHTransport;
    SSHClientIOHandler: TElClientIndySSHIOHandlerSocket;
    pTop: TPanel;
    SSHTCPClient: TIdTCPClient;
    procedure tmrRefreshTimer(Sender: TObject);
    procedure btnConnectClick(Sender: TObject);
    procedure edMessageKeyPress(Sender: TObject; var Key: Char);
    procedure btnRefreshClick(Sender: TObject);
    procedure FormCanResize(Sender: TObject; var NewWidth,
      NewHeight: Integer; var Resize: Boolean);
    procedure SSHTransportAuthenticationFailed(Sender: TObject;
      AuthenticationType: Integer);
    procedure SSHTransportAuthenticationSuccess(Sender: TObject);
    procedure SSHTransportKeyValidate(Sender: TObject;
      ServerKey: TElSSHKey; var Validate: Boolean);
    procedure SSHTransportCloseConnection(Sender: TObject);
    procedure SSHTransportOpenConnection(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    Login : string;
    { unfinished (before CRLF) string data, read from IOHandler }
    DataStr : string;
    { Private declarations }
    procedure SendText(const Text : string);
    function ReceiveString : string;
  public
  end;

var
  frmChatClient: TfrmChatClient;

implementation

{$R *.DFM}

procedure TfrmChatClient.tmrRefreshTimer(Sender: TObject);
var
  Com,
  Msg : String;
begin
  if not SSHTransport.Active then
    Exit;

  { trying to receive string }
  Msg := ReceiveString;

  if Msg <> '' then
    if Msg[1] <> '@' then
      begin
      { Not a command }
        memMessages.Lines.Add(Msg);
      end
    else
      begin
      { command }
        Com := UpperCase(Trim(Copy(Msg, 2, Pos(':', Msg) -2)));
        Msg := Trim(Copy(Msg, Pos(':', Msg) +1, Length(Msg)));
        { clients list }
        if Com = 'CLIENTS' then
          lbClients.Items.CommaText := Msg;
      end;
end;

procedure TfrmChatClient.btnConnectClick(Sender: TObject);
var
  FrmResult : integer;
  Pass : string;
begin
  if (edServer.Text <> '') and (btnConnect.Down) then
    FrmResult := frmLogin.ShowModal
  else if edServer.Text = '' then
  begin
    btnConnect.Down := false;
    ShowMessage('Enter valid server name.');
    Exit;
  end
  else
  begin
    { disconnecting from server }
    try
      SSHClientIOHandler.Close;
      SSHTransport.Disconnect;
      lbClients.Items.Clear;
    finally
      btnConnect.Down := false;
      memMessages.Lines.Add('** Disconnected.');
    end;
    Exit;
  end;

  if FrmResult = 1 then
  begin
    { connecting to server }
    DataStr := '';
    Login := frmLogin.edLogin.Text;
    Pass := frmLogin.edPassword.Text;
    frmLogin.edPassword.Text := '';
    memMessages.Lines.Add('** Connecting to ' + edServer.Text + ':'  + sePort.Text + '...');
    SSHTransport.Host := edServer.Text;
    SSHTransport.Port := sePort.Value;
    SSHTransport.Username := Login;
    SSHTransport.Password := Pass;
    try
      SSHTransport.Connect;
      { we are using subsystem ssh tunnel, named 'chat' }
      SSHClientIOHandler.Subsystem := 'chat';
      SSHClientIOHandler.Open;
    except
      on E : Exception do
      begin
        if SSHTransport.Active then
          SSHTransport.Disconnect;
        memMessages.Lines.Add('** Connection error : ' + E.Message);
        btnConnect.Down := false;
      end;
    end;
  end
  else
    btnConnect.Down := false;
end;

procedure TfrmChatClient.edMessageKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
    begin
      SendText('@MSG:' + edMessage.Text);
      edMessage.Text := '';
    end;
end;

procedure TfrmChatClient.btnRefreshClick(Sender: TObject);
begin
  if btnConnect.Down then
    SendText('@CLIENTS:REQUEST')
  else
    lbClients.Items.Clear;
end;

function TfrmChatClient.ReceiveString: string;
begin
  if SSHClientIOHandler.Connected then
  begin
    try
      if SSHTCPClient.IOHandler.Readable or (SSHTCPClient.InputBuffer.Size > 0) then
        Result := SSHTCPClient.ReadLn(#13#10, 0)
      else
        SSHTCPClient.Write(' ');
    except
      { receive error - disconnecting }
      on E : Exception do
      begin
        memMessages.Lines.Add('** Connection error : ' + E.Message);
        SSHTransport.Disconnect;
        btnConnect.Down := false;
      end;  
    end;
  end  
  else
    Result := '';
end;

procedure TfrmChatClient.SendText(const Text: string);
var
  St : string;
begin
  if SSHClientIOHandler.Connected then
  begin
    St := Text + #13#10;
    try
      SSHClientIOHandler.Send(St[1], Length(St));
    except
      { sending error - disconnecting }
      on E : Exception do
      begin
        memMessages.Lines.Add('** Connection error : ' + E.Message);
        SSHTransport.Disconnect;
        btnConnect.Down := false;
      end;  
    end;  
  end
  else
    memMessages.Lines.Add('** You aren''t connected.');
end;

procedure TfrmChatClient.FormCanResize(Sender: TObject; var NewWidth,
  NewHeight: Integer; var Resize: Boolean);
begin
  Resize := true;
  if NewWidth < 467 then
    NewWidth := 467;
end;

procedure TfrmChatClient.SSHTransportAuthenticationFailed(Sender: TObject;
  AuthenticationType: Integer);
begin
  { notification about incorrect password or login }
  if AuthenticationType = SSH_AUTH_TYPE_PASSWORD then
    memMessages.Lines.Add('** Error : incorrect login or password.');
end;

procedure TfrmChatClient.SSHTransportAuthenticationSuccess(
  Sender: TObject);
begin
  { succesfull notification }
  memMessages.Lines.Add('** Authentication succesfull.');
end;

procedure TfrmChatClient.SSHTransportKeyValidate(Sender: TObject;
  ServerKey: TElSSHKey; var Validate: Boolean);
var
  Fingerprint, Str : string;
  Res : integer;
  KeyFile : TextFile;
begin
  Fingerprint := DigestToStr(ServerKey.FingerprintSHA1);

  { searching for cashed server key fingerprint in file }

  if FileExists('.chat_keys') then
  try
    System.Assign(KeyFile, '.chat_keys');
    ReSet(KeyFile);
    while not EOF(KeyFile) do
    begin
      ReadLn(KeyFile, Str);

      if Str = Fingerprint then
      begin
        Validate := true;
        System.Close(KeyFile);
        Exit;
      end;
    end;

    System.Close(KeyFile);
  finally
  end;

  { we are first time connecting to server - asking user about key }
  Res := MessageBox(0, PAnsiChar('Server key fingerprint is ' + Fingerprint +
    '.'#13#10'If it corresponds to server, you are connecting to, press yes.'),
    'Server key validation', MB_YESNO);
  if Res = ID_YES then
  begin
    Validate := true;
    try
      System.Assign(KeyFile, '.chat_keys');

      if not FileExists('.chat_keys') then
        ReWrite(KeyFile)
      else
        Append(KeyFile);
      WriteLn(KeyFile, Fingerprint);
      System.Close(KeyFile);
    finally
    end;
  end  
  else
  begin
    Validate := false;
    memMessages.Lines.Add('** Server key validation failed : unknown key.');
  end;
end;

procedure TfrmChatClient.SSHTransportCloseConnection(Sender: TObject);
begin
  if btnConnect.Down then
  begin
    memMessages.Lines.Add('** Disconnected.');

    btnConnect.Down := SSHClientIOHandler.Connected and SSHTransport.Active;
    lbClients.Items.Clear;
  end;  
end;

procedure TfrmChatClient.SSHTransportOpenConnection(Sender: TObject);
begin
  memMessages.Lines.Add('** SSH connection established. Opening channel...');
end;

procedure TfrmChatClient.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  if btnConnect.Down then
  try
    SSHClientIOHandler.Close;
    SSHTransport.Disconnect;
    lbClients.Items.Clear;
  except
    btnConnect.Down := false;
  end;
end;


initialization

SetLicenseKey('ADDCD14AD06709806817E0B3D7BFD0A2222D536FE156466C5D5FE65DB5DEAE76' + 
  'FFDEBC07E915A5751C12C01C783958872A38E4A5EDA140E7247E0F2E56442A3C' + 
  'F3E9347AD8FDE52083A0DFC86BC00ECB0FD0CF1B51159A2BCB84F6EA6349EF47' + 
  '5C15A59AFCC55F7C3AAD26C279628B5D91B1DC94BD2385354A70CCA3B76101D9' + 
  'F41C84A639FC3CCE4BA8F0CC4A66DCD150114A3F58C1AD46B7B94643741BC20A' + 
  '8DCA83AB921480951B423CAA19EF1863A47CA2C3422E7E5634BED98939A5AE43' + 
  'DE1E4BAD79E66D8A5C973B3455656C8C9B6FF024FADD6CDA02D0F506D98493C8' + 
  'BD1ED7B237DB75FA31F2C82654490CDDDEE24E19939137B9E1DB05508733B22F');

end.