serverthread.pas

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

unit ServerThread;

interface

uses SysUtils,
  Winsock, ScktComp, SBSSHServer, SBSSHKeyStorage, SBSftpHandler, Classes,
  Windows, SBSSHCommon, SBUtils, SBSftpServer, SBSftpCommon, 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;
    FCurrentDir: widestring;
    SftpVersion: integer;
    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;
    //
    function FileInfoFromRec(r: TSearchRec): TElSftpFileInfo; virtual;
    function StatFile(name: string): TElSftpFileInfo; virtual;
    function StatOpenFile(Data : pointer): TElSftpFileInfo; virtual;
    //
    procedure OnSftpOpen(Sender: TObject);
    procedure OnSftpClose(Sender: TObject);
    procedure OnSftpCloseHandle(Sender: TObject; Data : pointer;
      var ErrorCode: integer; var Comment: string);
    procedure OnSftpCreateDirectory(Sender: TObject; const Path: string;
      Attributes: TElSftpFileAttributes; var ErrorCode: integer; var Comment: string);
    procedure OnSftpFindClose(Sender: TObject; Data : pointer;
      var ErrorCode: integer; var Comment: string);
    procedure OnSftpFindFirst(Sender: TObject; const Path: string;
      var Data: pointer; Info: TElSftpFileInfo; var ErrorCode: integer;
      var Comment: string);
    procedure OnSftpFindNext(Sender: TObject; Data: pointer; Info: TElSftpFileInfo;
      var ErrorCode: integer; var Comment: string);
    procedure OnSftpOpenFile(Sender: TObject; const Path: string;
      Modes: TSBSftpFileOpenModes; Access: TSBSftpFileOpenAccess;
      DesiredAccess : Cardinal; Attributes: TElSftpFileAttributes;
      var Data: pointer; var ErrorCode: integer; var Comment: string);
    procedure OnSftpReadFile(Sender: TObject; Data: pointer; Offset: Int64;
      Buffer: Pointer; Count: integer; var Read: integer; var ErrorCode: integer;
      var Comment: string);
    procedure OnSftpRemove(Sender: TObject; const Path: string;
      var ErrorCode: integer; var Comment: string);
    procedure OnSftpRenameFile(Sender: TObject; const OldPath, NewPath: string;
      Flags : TSBSftpRenameFlags; var ErrorCode: integer; var Comment: string);
    procedure OnSftpRequestAbsolutePath(Sender: TObject; const Path: string;
      var AbsolutePath: string; Control : TSBSftpRealpathControl; ComposePath : TStringList;
      var ErrorCode: integer; var Comment: string);
    procedure OnSftpRequestAttributes(Sender: TObject; const Path: string;
      FollowSymLinks: boolean; Attributes: TElSftpFileAttributes;
      var ErrorCode: integer; var Comment: string);
    procedure OnSftpRequestAttributes2(Sender: TObject;
      Data : pointer; Attributes: TElSftpFileAttributes; var ErrorCode: integer;
      var Comment: string);
    procedure OnSftpSetAttributes(Sender: TObject; const Path: string;
      Attributes: TElSftpFileAttributes; var ErrorCode: integer; var Comment: string);
    procedure OnSftpWriteFile(Sender: TObject; Data : pointer; Offset: Int64;
      Buffer: Pointer; Count: integer; var ErrorCode: integer; var Comment: string);
    procedure OnSrvFurtherAuthNeeded(Sender: TObject; const Username: string; var
        Needed: boolean);
  protected
    FAuthAllTypes: integer;
    FAuthAllUsername: string;
    procedure ClientExecute; override;
    procedure Execute; override;
    procedure OnSrvDebug(Sender : TObject; DebugStr : string);
  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
  SBSSHConstants, DemoSettings, SBSSHHandlers,
  SBSSHForwardingHandlers;

type
  PSearchRec = ^TSearchRec;


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');
  FCurrentDir := '/';
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;
  FSSHServer.AllowedSubsystems.Add('sftp');
  //FSSHServer.OnDebug := OnSrvDebug;
  //FSSHServer.DebugLevel := 10000;
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;
  if Accept then
    Log('Password authentication succeeded for user ' + Username);
end;

procedure TSSHServerThread.OnSrvAuthKeyboard(Sender: TObject; const Username : string;
  Submethods : TStringList; var Name: string; var Instruction: string;
  Requests : TStringList; Echoes : TBits);
begin
  Log('User ' + Username + ' tries Keyboard-interactive authentication');
  Name := '';
  Instruction := 'Please enter your username and password';
  Requests.Clear;
  Requests.Add('Username: ');
  Requests.Add('Password: ');
  Echoes.Size := 2;
  Echoes[0] := true;
  Echoes[1] := false;
end;

procedure TSSHServerThread.OnSrvAuthKeyboardResponse(Sender: TObject; Requests : TStringList;
  Responses: TStringList; var Name: string; var Instruction: string;
  NewRequests : TStringList; Echoes : TBits; var Accept : boolean);
begin
  if (Assigned(FOnAuthKeyboard)) and (Responses.Count = 2) then
  begin
    FCurrUsername := Responses[0];
    FCurrPassword := Responses[1];
    Synchronize(DoAuthKeyboard);
    Accept := FCurrBool;
  end
  else
    Accept := false;
  if Accept then
    Log('Keyboard-interactive authentication succeeded for user ' + Username);
end;

procedure TSSHServerThread.OnSrvSend(Sender : TObject; Buffer : pointer; Size : longint);
var
  Sent: integer;
  Ptr: ^byte;
begin
  Ptr := Buffer;
  if ClientSocket <> nil then
    while (Size > 0) and ClientSocket.Connected do
    begin
      Sent := ClientSocket.SendBuf(Ptr^, Size);
      Inc(Ptr, Sent);
      Dec(Size, Sent);
    end;
end;

procedure TSSHServerThread.OnSrvReceive(Sender : TObject; Buffer : pointer; MaxSize : longint; out Written : longint);
begin
  Written := ClientSocket.ReceiveBuf(Buffer^, MaxSize);
  if Written < 0 then
    Written := 0;
  if Written = 0 then
    Terminate;
end;

procedure TSSHServerThread.OnSrvOpen(Sender : TObject);
begin
  Log('SSH connection established');
  ChangeState(ssActive);
end;

procedure TSSHServerThread.OnSrvClose(Sender : TObject);
begin
  if not Terminated then
  begin
    Log('SSH connection closed');
    ChangeState(ssDisconnected);
  end;