serverthread.pas

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

unit ServerThread;

interface

uses SysUtils,
  ScktComp, SBSSHServer, SBSSHKeyStorage, Classes, Windows, SBSSHCommon,
  ServerForwardingThread;

type
  TSSHLogEvent = procedure(Sender: TObject; const S : string) of object;
  TSSHServerState = (ssConnecting, ssSecuring, ssAuthenticating, ssActive,
    ssDisconnected);
  TSSHServerThread = class(TServerClientThread)
  private
    FSSHServer: TElSSHServer;
    FHostKeys: TElSSHMemoryKeyStorage;
    FOnLog : TSSHLogEvent;
    FOnAuthAttempt: TSSHAuthAttemptEvent;
    FOnAuthPassword: TSSHAuthPasswordEvent;
    FOnAuthPublicKey: TSSHAuthPublicKeyEvent;
    FOnFurtherAuthNeeded: TSSHFurtherAuthNeededEvent;
    // note that this approach to keyboard-interactive user authentication is chosen
    // only as an example. You can ask as many questions as needed to authorize the user
    FOnAuthKeyboard : TSSHAuthPasswordEvent;

    FOnConnClosed: TNotifyEvent;
    FOnRefreshInfo: TNotifyEvent; 
    FCurrLogLine : string;
    FCurrUserName: string;
    FCurrAuthType: integer;
    FCurrPassword: string;
    FCurrBool: boolean;
    FCurrKey : TElSSHKey;
    FUsername : string;
    FSubsystemThreads : TList;
    FServerForwardings: TList;
    FState : TSSHServerState;
    procedure SetupServer;
    procedure SetupHostKeys;
    procedure OnSrvAuthAttempt(Sender : TObject; const Username : string;
      AuthType : integer; var Accept: boolean);
    procedure OnSrvAuthFailed(Sender : TObject; AuthenticationType : integer);
    procedure OnSrvAuthPublicKey(Sender : TObject; const Username : string;
      Key: TElSSHKey; var Accept : boolean);
    procedure OnSrvAuthPassword(Sender : TObject; const Username : string;
      const Password : string; var Accept : boolean; var ForceChangePassword: boolean);
    procedure OnSrvAuthKeyboard(Sender: TObject; const Username : string;
      Submethods : TStringList; var Name: string; var Instruction: string;
      Requests : TStringList; Echoes : TBits);
    procedure OnSrvAuthKeyboardResponse(Sender: TObject; Requests : TStringList;
      Responses: TStringList; var Name: string; var Instruction: string;
      NewRequests : TStringList; Echoes : TBits; var Accept : boolean);
    procedure OnSrvSend(Sender : TObject; Buffer : pointer; Size : longint);
    procedure OnSrvReceive(Sender : TObject; Buffer : pointer; MaxSize : longint; out Written : longint);
    procedure OnSrvOpen(Sender : TObject);
    procedure OnSrvClose(Sender : TObject);
    procedure OnSrvError(Sender : TObject; ErrorCode : integer);
    procedure OnSrvOpenShell(Sender: TObject; Conn: TElSSHTunnelConnection);
    procedure OnSrvOpenCommand(Sender: TObject; Conn: TElSSHTunnelConnection; const Command: string);
    procedure OnSrvOpenSubsystem(Sender: TObject; Conn: TElSSHTunnelConnection; const Subsystem: string);
    procedure OnSrvBeforeOpenClientForwarding(Sender: TObject; const DestHost: string;
      DestPort: integer; const SrcHost: string; SrcPort: integer; var Accept: boolean);
    procedure OnSrvOpenClientForwarding(Sender: TObject; Connection: TElSSHTunnelConnection;
      const DestHost: string; DestPort: integer; const SrcHost : string; SrcPort:
      integer);
    procedure OnSrvOpenServerForwarding(Sender: TObject;
      Connection: TElSSHTunnelConnection);
    procedure OnSrvServerForwardingFailed(Sender: TObject; Data: pointer);
    procedure OnSrvServerForwardingRequest(Sender: TObject; const Address: string;
      Port : integer; var Accept : boolean; var RealPort: integer);
    procedure OnSrvServerForwardingCancel(Sender: TObject; const Address: string;
      Port : integer);
    procedure OnForwardingSocketGetThread(Sender: TObject;
      ClientSocket: TServerClientWinSocket;
      var SocketThread: TServerClientThread);
    procedure OnThreadTerminate(Sender: TObject);
    procedure DoLog;
    procedure DoAuthAttempt;
    procedure DoAuthPassword;
    procedure DoAuthPublicKey;
    procedure DoAuthKeyboard;
    procedure DoConnClosed;
    procedure DoRefreshInfo;
    procedure DoFurtherAuthNeeded;
    procedure Log(const S : string);
    procedure ChangeState(NewState: TSSHServerState);
    function GetTunnelCount: integer;
    procedure OnSrvFurtherAuthNeeded(Sender: TObject; const Username: string; var
        Needed: boolean);
  protected
    FAuthAllTypes: integer;
    FAuthAllUsername: string;
    procedure ClientExecute; override;
    procedure Execute; override;
  public
    constructor Create(ASocket: TServerClientWinSocket);
    destructor Destroy; override;
    property AuthAllTypes: integer read FAuthAllTypes write FAuthAllTypes;
    property AuthAllUsername: string read FAuthAllUsername write FAuthAllUsername;

    property OnLog : TSSHLogEvent read FOnLog write FOnLog;
    property OnAuthAttempt: TSSHAuthAttemptEvent read FOnAuthAttempt write FOnAuthAttempt;
    property OnAuthPassword: TSSHAuthPasswordEvent read FOnAuthPassword write FOnAuthPassword;
    property OnAuthKeyboard : TSSHAuthPasswordEvent read FOnAuthKeyboard write FOnAuthKeyboard;
    property OnConnClosed: TNotifyEvent read FOnConnClosed write FOnConnClosed;
    property OnAuthPublicKey: TSSHAuthPublicKeyEvent read FOnAuthPublicKey write
        FOnAuthPublicKey;
    property OnFurtherAuthNeeded: TSSHFurtherAuthNeededEvent read
        FOnFurtherAuthNeeded write FOnFurtherAuthNeeded;
    property OnRefreshInfo: TNotifyEvent read FOnRefreshInfo write FOnRefreshInfo;
    property Username: string read FUsername;
    property State: TSSHServerState read FState;
    property TunnelCount: integer read GetTunnelCount;
  end;

implementation

uses
  Winsock, SBSSHConstants, DemoSettings, SBSSHHandlers,
  SBSSHForwardingHandlers;

function AuthTypeToStr(AuthType: integer): string;
begin
  case AuthType of
    SSH_AUTH_TYPE_RHOSTS: Result := 'Rhosts';
    SSH_AUTH_TYPE_PUBLICKEY: Result := 'PublicKey';
    SSH_AUTH_TYPE_PASSWORD: Result := 'Password';
    SSH_AUTH_TYPE_HOSTBASED: Result := 'Hostbased';
    SSH_AUTH_TYPE_KEYBOARD: Result := 'Keyboard-interactive';
  else
    Result := 'unknown'
  end;
end;

constructor TSSHServerThread.Create(ASocket: TServerClientWinSocket);
begin
  inherited Create(true, ASocket);
  FSSHServer := TElSSHServer.Create(nil);
  FHostKeys := TElSSHMemoryKeyStorage.Create(nil);
  Synchronize(SetupHostKeys);
  SetupServer;
  FSubsystemThreads := TList.Create;
  FServerForwardings := TList.Create;
  Log('Server instance is ready');
end;

destructor TSSHServerThread.Destroy;
var
  I : integer;
begin
  for I := 0 to FSubsystemThreads.Count - 1 do
    TThread(FSubsystemThreads[I]).Terminate;
  FreeAndNil(FSubsystemThreads);

  for I := 0 to FServerForwardings.Count - 1 do
  begin
    TServerSocket(FServerForwardings[I]).Close;
    TServerSocket(FServerForwardings[I]).Free;
  end;
  if FSSHServer.Active then
    FSSHServer.Close(true);
  FreeAndNil(FServerForwardings);
  FreeAndNil(FSSHServer);
  FreeAndNil(FHostKeys);
  inherited;
end;

procedure TSSHServerThread.Execute;
begin
  ChangeState(ssConnecting);
  FSSHServer.Open;
  inherited;
end;

procedure TSSHServerThread.ClientExecute;
var
  FDSet: TFDSet;
  TimeVal: TTimeVal;
begin
  ChangeState(ssSecuring);
  while not Terminated and ClientSocket.Connected do
  begin
    try
      FD_ZERO(FDSet);
      FD_SET(ClientSocket.SocketHandle, FDSet);
      TimeVal.tv_sec := 0;
      TimeVal.tv_usec := 500000;
      if (select(0, @FDSet, nil, nil, @TimeVal) > 0) and not Terminated then
        FSSHServer.DataAvailable
      else
        Sleep(500);
    except
      break;
    end;
  end;
  try
    if FSSHServer.Active then
      FSSHServer.Close(not ClientSocket.Connected);
    if ClientSocket.Connected then
      ClientSocket.Close;
  except
  end;
  ChangeState(ssDisconnected);
  Synchronize(DoConnClosed);
end;

procedure TSSHServerThread.SetupHostKeys;
var
  Key: TElSSHKey;
begin
  if Length(Settings.HostKey) > 0 then
  begin
    Key := TElSSHKey.Create;
    try
      if Key.LoadPrivateKey(@Settings.HostKey[1], Length(Settings.HostKey)) = 0 then
        FHostKeys.Add(Key);
    finally
      Key.Free;
    end;
  end;
end;

procedure TSSHServerThread.SetupServer;
begin
  FSSHServer.SoftwareName := 'SSHBlackbox(VCL)';
  FSSHServer.OnAuthAttempt := OnSrvAuthAttempt;
  FSSHServer.OnAuthFailed := OnSrvAuthFailed;
  FSSHServer.OnAuthPassword := OnSrvAuthPassword;
  FSSHServer.OnAuthPublicKey := OnSrvAuthPublicKey;
  FSSHServer.OnAuthKeyboard := OnSrvAuthKeyboard;
  FSSHServer.OnAuthKeyboardResponse := OnSrvAuthKeyboardResponse;
  FSSHServer.OnFurtherAuthNeeded := OnSrvFurtherAuthNeeded;
  FSSHServer.OnSend := OnSrvSend;
  FSSHServer.OnReceive := OnSrvReceive;
  FSSHServer.OnOpenConnection := OnSrvOpen;
  FSSHServer.OnCloseConnection := OnSrvClose;
  FSSHServer.OnError := OnSrvError;
  FSSHServer.OnOpenShell := OnSrvOpenShell;
  FSSHServer.OnOpenCommand := OnSrvOpenCommand;
  FSSHServer.OnOpenSubsystem := OnSrvOpenSubsystem;
  FSSHServer.OnBeforeOpenClientForwarding := OnSrvBeforeOpenClientForwarding;
  FSSHServer.OnOpenClientForwarding := OnSrvOpenClientForwarding;
  FSSHServer.OnOpenServerForwarding := OnSrvOpenServerForwarding;
  FSSHServer.OnServerForwardingFailed := OnSrvServerForwardingFailed;
  FSSHServer.OnServerForwardingRequest := OnSrvServerForwardingRequest;
  FSSHServer.OnServerForwardingCancel := OnSrvServerForwardingCancel;
  FSSHServer.KeyStorage := FHostKeys;
end;

procedure TSSHServerThread.OnSrvAuthAttempt(Sender : TObject; const Username : string;
  AuthType : integer; var Accept: boolean);
begin
  Log('User ' + Username + ' requests ' + AuthTypeToStr(AuthType) + ' authentication');
  ChangeState(ssAuthenticating);
  if FAuthAllUsername <> UserName then
  begin
    FAuthAllTypes := 0;
    FSSHServer.AuthenticationTypes := SSH_AUTH_TYPE_PASSWORD or SSH_AUTH_TYPE_PUBLICKEY or
      SSH_AUTH_TYPE_KEYBOARD;
    FAuthAllUsername := UserName;
  end;
  if Assigned(FOnAuthAttempt) then
  begin
    FCurrUsername := Username;
    FCurrAuthType := AuthType;
    FUsername := Username;
    Synchronize(DoAuthAttempt);
    Accept := FCurrBool;
  end
  else
    Accept := false;
end;

procedure TSSHServerThread.OnSrvAuthFailed(Sender : TObject; AuthenticationType : integer);
begin
  Log('Authentication attempt (' + AuthTypeToStr(AuthenticationType) + ') failed');
end;

procedure TSSHServerThread.OnSrvAuthPublicKey(Sender : TObject; const Username : string;
  Key: TElSSHKey; var Accept : boolean);
begin
  Log('User ' + Username + ' tries PublicKey authentication');
  FCurrKey := Key;
  if Assigned(FOnAuthPublicKey) then
    Synchronize(DoAuthPublicKey);
  Accept := FCurrBool;
  if Accept then
    Log('User ' + Username + ' is allowed to try PublicKey authentication');
end;

procedure TSSHServerThread.OnSrvAuthPassword(Sender : TObject; const Username : string;
  const Password : string; var Accept : boolean; var ForceChangePassword: boolean);
begin
  Log('User ' + Username + ' tries Password authentication');
  if Assigned(FOnAuthPassword) then
  begin
    FCurrUsername := Username;
    FCurrPassword := Password;
    Synchronize(DoAuthPassword);
    Accept := FCurrBool;
  end
  else
    Accept := false;
  ForceChangePassword := false;