mainform.pas

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

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SBUtils, SBSSHCommon, SBSSHConstants, SBSSHServer, Menus, ToolWin, ComCtrls,
  ExtCtrls, ScktComp,
  ImgList, ServerThread, SBSSHHandlers, SBSSHKeyStorage, SyncObjs;

type
  TfrmMain = class(TForm)
    MainMenu: TMainMenu;
    mnuServer: TMenuItem;
    mnuStart: TMenuItem;
    mnuStop: TMenuItem;
    mnuBreak: TMenuItem;
    mnuExit: TMenuItem;
    mnuHelp: TMenuItem;
    mnuAbout: TMenuItem;
    ToolBar: TToolBar;
    btnStart: TToolButton;
    btnStop: TToolButton;
    btnDelim1: TToolButton;
    btnAuthSettings: TToolButton;
    pLog: TPanel;
    Splitter: TSplitter;
    pClient: TPanel;
    lvLog: TListView;
    lvConnections: TListView;
    ServerSocket: TServerSocket;
    btnServerSettings: TToolButton;
    StatusBar: TStatusBar;
    ImageListLog: TImageList;
    ImageListClients: TImageList;
    ImageListToolbar: TImageList;
    btnDelim2: TToolButton;
    btnKillConn: TToolButton;
    procedure ServerSocketGetThread(Sender: TObject;
      ClientSocket: TServerClientWinSocket;
      var SocketThread: TServerClientThread);
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure btnAuthSettingsClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnServerSettingsClick(Sender: TObject);
    procedure mnuStartClick(Sender: TObject);
    procedure mnuStopClick(Sender: TObject);
    procedure mnuExitClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure btnKillConnClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
    FActive: boolean;
    FThreadListAccess: TCriticalSection;
    FFinalizing : boolean;
    procedure ServerThreadLog(Sender: TObject; const S: string); 
    procedure ServerThreadAuthAttempt(Sender : TObject; const Username : string;
      AuthType : integer; var Accept: boolean);
    procedure ServerThreadAuthPassword(Sender : TObject; const Username : string;
      const Password : string; var Accept : boolean; var ForceChangePassword: boolean);
    procedure ServerThreadAuthKeyboard(Sender: TObject; const Username: string;
      const Password: string; var Accept: boolean; var ForceChangePassword: boolean);
    procedure ServerThreadConnClosed(Sender: TObject);
    procedure ServerThreadRefreshInfo(Sender: TObject);
    procedure AddClientToList(ServerThread: TSSHServerThread);
    procedure ServerThreadFurtherAuthNeeded(Sender: TObject; const Username: string;
        var Needed: boolean);
    procedure RemoveClientFromList(ServerThread: TSSHServerThread);
    procedure RefreshClientInfo(ServerThread: TSSHServerThread);
    procedure ServerThreadAuthPublicKey(Sender: TObject; const Username: string;
      Key: TElSSHKey; var Accept: boolean);
  public
    procedure Initialize;
    procedure Finalize;
    procedure Start;
    procedure Stop;
    procedure ExitApp;
    procedure AuthSettings;
    procedure ServerSettings;
    procedure About;
    procedure Log(const S : string; Error: boolean = false);
  end;

var
  frmMain: TfrmMain;

implementation

uses
  ConnPropsForm,
  AuthSettingsForm,
  ServerSettingsForm,
  DemoSettings, AboutForm;

{$R *.DFM}

procedure TfrmMain.Initialize;
begin
  FActive := false;
  StatusBar.Panels[0].Text := 'Inactive';
  FThreadListAccess := TCriticalSection.Create();
  FFinalizing := false;
end;

procedure TfrmMain.Finalize;
var
  I : integer;
  Thr : array of TSSHServerThread;
begin
  FFinalizing := true;
  SetLength(Thr, lvConnections.Items.Count);
  FThreadListAccess.Enter;
  try
    for I := 0 to lvConnections.Items.Count - 1 do
      Thr[I] := lvConnections.Items[I].Data;
  finally
    FThreadListAccess.Free;
  end;
  for I := 0 to Length(Thr) - 1 do
    Thr[I].Terminate;
end;

procedure TfrmMain.Start;
begin
  if not FActive then
  begin
    if frmConnProps.ShowModal = mrOk then
    begin
      if ServerSocket.Active then
        ServerSocket.Close;
      ServerSocket.Port := StrToIntDef(frmConnProps.editPort.Text, 22);
      ServerSocket.Open;
      StatusBar.Panels[0].Text := 'Active';
      FActive := true;
      Log('Server started');
    end;
  end
  else
    MessageDlg('Server is already running', mtWarning, [mbOk], 0);
end;

procedure TfrmMain.Stop;
begin
  if FActive then
  begin
    if ServerSocket.Active then
      ServerSocket.Close;
    StatusBar.Panels[0].Text := 'Inactive';
    Log('Server stopped');
    FActive := false;
  end
  else
    MessageDlg('Server is already halted', mtWarning, [mbOk], 0);
end;

procedure TfrmMain.ExitApp;
begin
  Close;
end;

procedure TfrmMain.AuthSettings;
begin
  frmAuthSettings.ShowModal;
end;

procedure TfrmMain.ServerSettings;
begin
  frmServerSettings.ShowModal;
end;

procedure TfrmMain.About;
begin
  frmAbout.ShowModal;
end;

procedure TfrmMain.Log(const S : string; Error: boolean = false);
var
  Item: TListItem;
begin
  if not FFinalizing then
  begin
    Item := lvLog.Items.Add;
    Item.Caption := TimeToStr(Now);
    Item.ImageIndex := 0;
    Item.SubItems.Add(S);
  end;
end;

procedure TfrmMain.ServerSocketGetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  Log('Client connection established [' + ClientSocket.RemoteAddress + ']');
  SocketThread := TSSHServerThread.Create(ClientSocket);
  TSSHServerThread(SocketThread).OnLog := ServerThreadLog;
  TSSHServerThread(SocketThread).OnAuthAttempt := ServerThreadAuthAttempt;
  TSSHServerThread(SocketThread).OnFurtherAuthNeeded := ServerThreadFurtherAuthNeeded;
  TSSHServerThread(SocketThread).OnAuthPassword := ServerThreadAuthPassword;
  TSSHServerThread(SocketThread).OnAuthPublicKey := ServerThreadAuthPublicKey;
  TSSHServerThread(SocketThread).OnAuthKeyboard := ServerThreadAuthKeyboard;
  SocketThread.FreeOnTerminate := true;
  TSSHServerThread(SocketThread).OnConnClosed := ServerThreadConnClosed;
  TSSHServerThread(SocketThread).OnRefreshInfo := ServerThreadRefreshInfo;
  AddClientToList(TSSHServerThread(SocketThread));
  SocketThread.Resume;
end;

procedure TfrmMain.btnStartClick(Sender: TObject);
begin
  Start;
end;

procedure TfrmMain.btnStopClick(Sender: TObject);
begin
  Stop;
end;

procedure TfrmMain.btnAuthSettingsClick(Sender: TObject);
begin
  AuthSettings;
end;

procedure TfrmMain.btnServerSettingsClick(Sender: TObject);
begin
  ServerSettings;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Initialize;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  Finalize;
end;

procedure TfrmMain.ServerThreadLog(Sender: TObject; const S: string);
begin
  Log(S, false);
end;

procedure TfrmMain.ServerThreadAuthAttempt(Sender : TObject; const Username : string;
  AuthType : integer; var Accept: boolean);
var
  Index: integer;
begin
  Index := Settings.FindUser(Username);
  if Index >= 0 then
  begin
    Accept := (Settings.Users[Index].AuthTypes and AuthType) = AuthType;
  end
  else
    Accept := false;
end;

procedure TfrmMain.ServerThreadAuthPublicKey(Sender: TObject; const Username: string;
    Key: TElSSHKey; var Accept: boolean);
var
  Index: integer;
begin
  Index := Settings.FindUser(Username);
  if Index >= 0 then
  begin
    Accept := Settings.Users[Index].KeyValid(Key);
    if Accept and Settings.Users[Index].AuthAll then
      TSSHServerThread(Sender).AuthAllTypes := TSSHServerThread(Sender).AuthAllTypes or SSH_AUTH_TYPE_PUBLICKEY;
  end
  else
    Accept := false;
end;

procedure TfrmMain.ServerThreadAuthPassword(Sender : TObject; const Username : string;
  const Password : string; var Accept : boolean; var ForceChangePassword: boolean);
var
  Index: integer;
begin
  Index := Settings.FindUser(Username);
  if Index >= 0 then
  begin
    Accept := Settings.Users[Index].PasswordValid(Password);
    if Accept and Settings.Users[Index].AuthAll then
      TSSHServerThread(Sender).AuthAllTypes := TSSHServerThread(Sender).AuthAllTypes or SSH_AUTH_TYPE_PASSWORD;
  end
  else
    Accept := false;
end;

procedure TfrmMain.ServerThreadConnClosed(Sender: TObject);
begin
  RemoveClientFromList(TSSHServerThread(Sender));
end;

procedure TfrmMain.ServerThreadRefreshInfo(Sender: TObject);
begin
  if not FFinalizing then
    RefreshClientInfo(TSSHServerThread(Sender));
end;

procedure TfrmMain.AddClientToList(ServerThread: TSSHServerThread);
var
  Item : TListItem;
begin
  FThreadListAccess.Enter;
  try
    Item := lvConnections.Items.Add;
    Item.Caption := ServerThread.ClientSocket.RemoteAddress;
    Item.SubItems.Add(ServerThread.Username);
    Item.SubItems.Add('Connecting');
    Item.Data := ServerThread;
    Item.ImageIndex := 0;
  finally
    FThreadListAccess.Leave;
  end;
end;

procedure TfrmMain.RemoveClientFromList(ServerThread: TSSHServerThread);
var
  I : integer;
begin
  FThreadListAccess.Enter;
  try
    for I := 0 to lvConnections.Items.Count - 1 do
    begin
      if lvConnections.Items[I].Data = ServerThread then
      begin
        lvConnections.Items.Delete(I);
        Break;
      end;
    end;
  finally
    FThreadListAccess.Leave;
  end;
end;

procedure TfrmMain.RefreshClientInfo(ServerThread: TSSHServerThread);
var
  I : integer;
  function StateStr(State: TSSHServerState): string;
  begin
    case State of
      ssConnecting: Result := 'Connecting';
      ssSecuring: Result := 'Securing';
      ssAuthenticating: Result := 'Authenticating';
      ssActive: Result := 'Active';
      ssDisconnected: Result := 'Disconnected';
    else
      Result := '';
    end;
  end;
begin
  FThreadListAccess.Enter;
  try
    for I := 0 to lvConnections.Items.Count - 1 do
    begin
      if lvConnections.Items[I].Data = ServerThread then
      begin
        lvConnections.Items[I].SubItems.Clear;
        lvConnections.Items[I].Caption := ServerThread.ClientSocket.RemoteAddress;
        lvConnections.Items[I].SubItems.Add(ServerThread.Username);
        lvConnections.Items[I].SubItems.Add(StateStr(ServerThread.State));
        lvConnections.Items[I].SubItems.Add(IntToStr(ServerThread.TunnelCount));
        Break;
      end;
    end;
  finally
    FThreadListAccess.Leave;
  end;
end;


procedure TfrmMain.mnuStartClick(Sender: TObject);
begin
  Start;
end;

procedure TfrmMain.mnuStopClick(Sender: TObject);
begin
  Stop;
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
  ExitApp;
end;

procedure TfrmMain.mnuAboutClick(Sender: TObject);
begin
  About;
end;

procedure TfrmMain.btnKillConnClick(Sender: TObject);
begin
  if (lvConnections.Selected <> nil) and (lvConnections.Selected.Data <> nil) then
  begin
    TSSHServerThread(lvConnections.Selected.Data).Terminate;
    RemoveClientFromList(lvConnections.Selected.Data);
  end;
end;

procedure TfrmMain.FormActivate(Sender: TObject);
begin
  if not Settings.SettingsFound then
  begin
    MessageDlg('Welcome to the ElSSHServer Demo Application!'#13#10 +
      'Thank you for your interest in our products.'#13#10#13#10 +
      'First of all, you need to create at least one user account.'#13#10 +
      'After clicking the OK button you will be redirected to the'#13#10 +
      'User settings window.',
      mtInformation,
      [mbOk],
      0);
    frmAuthSettings.ShowModal;       
  end;
end;

procedure TfrmMain.ServerThreadFurtherAuthNeeded(Sender: TObject; const
    Username: string; var Needed: boolean);
var
  Index: integer;
begin
  Index := Settings.FindUser(Username);
  if (Index < 0) or (not Settings.Users[Index].AuthAll) then
    Needed := false
  else
    Needed := TSSHServerThread(Sender).AuthAllTypes <> Settings.Users[Index].AuthTypes;
end;


procedure TfrmMain.ServerThreadAuthKeyboard(Sender: TObject;
  const Username, Password: string; var Accept,
  ForceChangePassword: boolean);
var
  Index: integer;
begin
  Index := Settings.FindUser(Username);
  if Index >= 0 then
  begin
    Accept := Settings.Users[Index].PasswordValid(Password);
    if Accept and Settings.Users[Index].AuthAll then
      TSSHServerThread(Sender).AuthAllTypes := TSSHServerThread(Sender).AuthAllTypes or SSH_AUTH_TYPE_KEYBOARD;
  end
  else
    Accept := false;
end;

end.