mainform.pas

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

unit MainForm;

interface

uses
  Windows, Messages, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls,
  ExtCtrls, ToolWin, ImgList, Spin, Menus, SysUtils, Classes, IdBaseComponent,
  IdComponent, IdTCPServer, IdServerIOHandler, IdServerIOHandlerSocket,
  SBConstants, SBCustomCertStorage, SBSSHCommon, SBSSHServer, SBSSHConstants,
  SBSSHKeyStorage, SBSharedResource,IdThreadComponent, IdGlobal, IdAntiFreezeBase,
  KeyPassword, SBUtils, SBSHA, SBIndySSHServerIOHandler9;

type
  TSimpleClient = class(TObject)
  protected
    { SSHClientServerIOHandler.OnOpenConnection handler }
    procedure HandleOpenConnection(Sender : TObject;
      Connection : TElIdSSHConnection);
    procedure HandleAuthPassword(Sender: TObject; const Username: string;
      const Password: string; var Accept: boolean; var ForceChangePassword:
      boolean);
    procedure HandleAuthAttempt(Sender: TObject; const Username: string;
      AuthType: integer; var Accept: boolean);
    procedure HandleError(Sender : TObject; ErrorCode : integer);
  public
    DNS, Name : String;
    Thread : TIdPeerThread;
    SSHVersion : TSSHVersion;
    SSHCSIOHandler : TElIdSSHClientServerIOHandler;
    SSHDataConnection : TElIdSSHConnection;

    constructor Create; virtual;
    destructor Destroy; override;
  end;

  TAllowedClientInfo = class(TObject)
    Login : string;
    Digest : TMessageDigest160;
    HasPassword : boolean;
  end;

  TfrmMain = class(TForm)
    dlgLoadKey: TOpenDialog;
    btnRefresh: TButton;
    btnSave: TButton;
    procedure btnRefreshClick(Sender: TObject);
    procedure btnAddUserClick(Sender: TObject);
    procedure btnSetPasswordClick(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure btnDelUserClick(Sender: TObject);
  published
    SSHIOHandler: TElIdSSHServerIOHandler;
    ServerKeyStorage: TElSSHMemoryKeyStorage;
    lServerKey: TLabel;
    lServerKeyInfo: TLabel;
    btnLoadKey: TButton;
    tsLog: TTabSheet;
    memLog: TMemo;
    tsUsers: TTabSheet;
    lbAllowedUsers: TListBox;
    lAllowedUsers: TLabel;
    btnAddUser: TButton;
    btnDelUser: TButton;
    btnSetPassword: TButton;
    StatusBar1: TStatusBar;
    Panel1: TPanel;
    Panel2: TPanel;
    lbClients: TListBox;
    pcMain: TPageControl;
    tsClientInformation: TTabSheet;
    tsServerInformation: TTabSheet;
    ImageList1: TImageList;
    Label3: TLabel;
    lblDNS: TLabel;
    tcpServer: TIdTCPServer;
    Label4: TLabel;
    seBinding: TSpinEdit;
    Label6: TLabel;
    memEntry: TMemo;
    Label7: TLabel;
    memEMotes: TMemo;
    lClientName: TLabel;
    lClientDNS: TLabel;
    puLogMenu: TPopupMenu;
    Savetofile1: TMenuItem;
    Loadfromfile1: TMenuItem;
    dlgOpen: TOpenDialog;
    dlgSave: TSaveDialog;
    ToolBar1: TToolBar;
    btnServerUp: TToolButton;
    ToolButton1: TToolButton;
    btnKillClient: TToolButton;
    btnClients: TToolButton;
    Label12: TLabel;
    edSysopName: TEdit;
    lClientSoftware: TLabel;
    IdThreadComponent1: TIdThreadComponent;

    procedure btnLoadKeyClick(Sender: TObject);
    procedure btnServerUpClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure seBindingChange(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Savetofile1Click(Sender: TObject);
    procedure Loadfromfile1Click(Sender: TObject);
    procedure btnClientsClick(Sender: TObject);
    procedure btnKillClientClick(Sender: TObject);
    procedure lbClientsClick(Sender: TObject);
    procedure tcpServerConnect(AThread: TIdPeerThread);
    procedure tcpServerDisconnect(AThread: TIdPeerThread);
    procedure tcpServerExecute(AThread: TIdPeerThread);
  private
    { Private declarations }
    ClientsSharedResource : TElSharedResource;

    procedure DisconnectClient(Client : TSimpleClient; const Reason : string);
    procedure SendText(Client : TSimpleClient; const Msg : string);
    function RecvText(Client : TSimpleClient) : string;
    procedure AddToLog(const  Str : string);
    procedure SetServerKey(Key : TElSSHKey);
    procedure UpdateAllowedClientsList;
    procedure LoadAllowedClientsList;

    function ClientList : string;
  public
    { Public declarations }
    Clients  : TList;
    AllowedClients : TList;
    procedure UpdateBindings;
    procedure UpdateClientList;
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

uses
  IdSocketHandle;

procedure TfrmMain.UpdateBindings;
var
  Binding : TIdSocketHandle;
begin
{ Set the TIdTCPServer's port to the chosen value }
  tcpServer.DefaultPort := seBinding.Value;
{ Remove all bindings that currently exist }
  tcpServer.Bindings.Clear;
{ Create a new binding }
  Binding := tcpServer.Bindings.Add;
{ Assign that bindings port to our new port }
  Binding.Port := seBinding.Value;
end;

procedure TfrmMain.btnServerUpClick(Sender: TObject);
var
  Index : integer;
begin
  try
  { Check to see if the server is online or offline }
    if btnServerUp.Down and (not tcpServer.Active) then
    begin
      { starting up server }
      if ServerKeyStorage.Count = 0 then
      begin
        ShowMessage('You need to load server key first.');
        btnServerUp.Down := false;
        Exit;
      end;
    end;

    if tcpServer.Active and (not btnServerUp.Down) then
    begin
      if (Clients.Count > 0) then
      begin
        for Index := 0 to Clients.Count - 1 do
          DisconnectClient(Clients[Index], 'Server shutdown.');

        { waiting all clients to terminate }
        while Clients.Count > 0 do
        begin
          Sleep(100);
        end;
      end;
    end;

    tcpServer.Active := not tcpServer.Active;
    btnServerUp.Down := tcpServer.Active;
    if btnServerUp.Down then
      begin
      { Server is online }
        AddToLog('** Server started.');
        btnServerUp.ImageIndex := 1;
        btnServerUp.Hint       := 'Shut down server';
      end
    else
      begin
      { Server is offline }
        AddToLog('** Server shutdown.');
        btnServerUp.ImageIndex := 0;
        btnServerUp.Hint       := 'Start up server';
      end;
  { Setup GUI buttons }
    btnClients.Enabled:= btnServerUp.Down;
    seBinding.Enabled := not btnServerUp.Down;
    edSysopName.Enabled:= not btnServerUp.Down;
  except
  { If we have a problem then rest things }
    on E : Exception do
    begin
      AddToLog('** Error : ' + E.Message);
      btnServerUp.Down  := false;
      seBinding.Enabled := not btnServerUp.Down;
      btnClients.Enabled:= btnServerUp.Down;
      edSysopName.Enabled:= not btnServerUp.Down;
    end;
  end;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
  Key : TElSSHKey;
  Res : integer;
begin
  AllowedClients := TList.Create;
  { Initalize our clients list }
  Clients := TList.Create;
  ClientsSharedResource := TElSharedResource.Create;
  { Call updatebindings so that the servers bindings are correct }
  UpdateBindings;
  { Get the local DNS entry for this computer }
  lblDNS.Caption := tcpServer.Bindings.Items[0].PeerIP;
  { Initializing SSHServerIOHandler }
  SSHIOHandler.AllowedSubsystems.Add('chat');

  { creating password request form, it can be needed below }
  frmPassword := TfrmPassword.Create(Self);
  frmPassword.Visible := false;
  if FileExists('.chat_server_key') then
  begin
    Key := TElSSHKey.Create;
    try
      Res := Key.LoadPrivateKey('.chat_server_key', '');

      if Res = 0 then
        SetServerKey(Key)
      else
      if Res = SB_ERROR_SSH_KEYS_INVALID_PASSPHRASE then
      begin
        { passphrase needed to unlock key }
        Res := frmPassword.ShowModal;
        if Res = mrOk then
        begin
          Res := Key.LoadPrivateKey('.chat_server_key', frmPassword.edPassword.Text);
          if Res = 0 then
            SetServerKey(Key)
          else
            Application.MessageBox('Incorrect passphrase!','Error', MB_OK);
        end;
      end;
    finally
      Key.Free;
    end;
  end;

  { loading allowed users list }
  LoadAllowedClientsList;
end;

procedure TfrmMain.SetServerKey(Key : TElSSHKey);
var
  Str, AlgStr : string;
begin
  if Assigned(Key) then
  begin
    ServerKeyStorage.Clear;
    ServerKeyStorage.Add(Key);
    Str := Key.Comment;
    if Key.Algorithm = ALGORITHM_RSA then
      AlgStr := 'RSA'
    else if Key.Algorithm = ALGORITHM_DSS then
      AlgStr := 'DSS'
    else
      AlgStr := 'Unknown';

    Str := Str + Format(' (%s, %d bits)', [AlgStr, Key.Bits]);
    lServerKeyInfo.Caption := Str;
    Key.SavePrivateKey('.chat_server_key');
  end
  else
  begin
    ServerKeyStorage.Clear;
    lServerKeyInfo.Caption := '(no key loaded)';
  end;
end;

procedure TfrmMain.seBindingChange(Sender: TObject);
begin
  UpdateBindings;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
var
  Index : integer;
begin
  if (Clients.Count > 0) then
  begin
    for Index := 0 to Clients.Count - 1 do
      DisconnectClient(Clients[Index], 'Server shutdown.');
  end;

  { wait all clients to disconnect }
  while Clients.Count > 0 do
  begin
    Sleep(100);
  end;

  { saving allowed clients list }
  btnSaveClick(Self);
  { freeing allowed clients }
  for Index := 0 to AllowedClients.Count - 1 do
    TAllowedClientInfo(AllowedClients[Index]).Free;
  AllowedClients.Free;

  tcpServer.Active := false;

  Clients.Free;
  ClientsSharedResource.Free;
end;

procedure TfrmMain.Savetofile1Click(Sender: TObject);
begin
  if not (puLogMenu.PopupComponent is TMemo) then
    Exit;

  if dlgSave.Execute then
    begin
      TMemo(puLogMenu.PopupComponent).Lines.SaveToFile(dlgSave.FileName);
    end;
end;

procedure TfrmMain.Loadfromfile1Click(Sender: TObject);
begin
  if not (puLogMenu.PopupComponent is TMemo) then
    exit;

  if dlgOpen.Execute then
    begin
      TMemo(puLogMenu.PopupComponent).Lines.LoadFromFile(dlgOpen.FileName);
    end;
end;

procedure TfrmMain.UpdateClientList;
var
  Index : Integer;
begin
  { setting names of the clietns }
  ClientsSharedResource.WaitToRead;
  try
    for Index := 0 to Clients.Count - 1 do
      if Index > lbClients.Items.Count then
        lbClients.Items.Add(TSimpleClient(Clients.Items[Index]).Name)
      else
        lbClients.Items[Index] := TSimpleClient(Clients.Items[Index]).Name;

    { cutting off disconnected clients }
    if Clients.Count < lbClients.Items.Count then
      for Index := lbClients.Items.Count - 1 downto Clients.Count do
        lbClients.Items.Delete(Index);
    lbClientsClick(Self);    
  finally
    ClientsSharedResource.Done;
  end;
end;


procedure TfrmMain.btnClientsClick(Sender: TObject);
begin
  UpdateClientList;
end;

procedure TfrmMain.btnKillClientClick(Sender: TObject);
var
  Msg : String;
  Index : integer;
begin
  Msg := InputBox('Disconnect message', 'Enter a reason for the disconnect', '');
  Msg := Trim(Msg);
  Index := lbClients.ItemIndex;

  if Index >=0 then
  begin
    ClientsSharedResource.WaitToRead;
    try
      AddToLog('** Killing connection to client ' + lbClients.Items[Index]);
      DisconnectClient(Clients[Index], Msg);
    finally
      ClientsSharedResource.Done;
    end;  
  end;
end;

procedure TfrmMain.lbClientsClick(Sender: TObject);
var
  Client : TSimpleClient;
begin
  { updating some labels with client info, and 'kill client' button }
  btnKillClient.Enabled := lbClients.ItemIndex <> -1;

  if lbClients.ItemIndex = -1 then
  begin
    lClientName.Caption := 'Client name: None selected';
    lClientDNS.Caption  := 'Client DNS: None selected';
    lClientSoftware.Caption := 'Client software: None selected';

    Exit;
  end;

  { locking clients list }
  ClientsSharedResource.WaitToRead;
  try
    Client := Clients.Items[lbClients.ItemIndex];

    if Assigned(Client.SSHCSIOHandler) and (Client.SSHCSIOHandler.Active) then
    begin
      lClientName.Caption := 'Client name: ' + Client.Name;
      lClientDNS.Caption  := 'Client DNS: ' + Client.DNS;
      lClientSoftware.Caption := 'Client software: ' + Client.SSHCSIOHandler.ClientSoftwareName;
    end
    else
    begin
      lClientName.Caption := 'Client name: None selected';
      lClientDNS.Caption  := 'Client DNS: None selected';
      lClientSoftware.Caption := 'Client software: None selected';
    end;
  finally
    ClientsSharedResource.Done;
  end;
end;

procedure TfrmMain.tcpServerConnect(AThread: TIdPeerThread);
var
  Client : TSimpleClient;
begin
  AddToLog('** New TCP connection from ' + AThread.Connection.Socket.Binding.IP);
  if Assigned(AThread.Connection.IOHandler) and
    (AThread.Connection.IOHandler is TElIdSSHClientServerIOHandler) then
  begin
    ClientsSharedResource.WaitToWrite;
    try
      Client := TSimpleClient.Create;
    { Assign its default values }
      Client.DNS  := AThread.Connection.Socket.Binding.PeerIP;
      Client.Name := AThread.Connection.Socket.Binding.PeerIP;