serverthread.pas

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

      hu := copy(p, 1, i - 1);
      delete(p, 1, i);
    end
    else
    begin
      hu := p;
      p := '';
    end;
    if hu = '.' then
      continue;
    if hu = '..' then
    begin
      us := UpDir(us);
      continue;
    end;
    us := us + '/' + hu;
    i := pos('/', p);
  end;
  result := us + p;
  if result = '' then
    result := '/';
  if d <> '' then
    result := d + result;
end;

function FormRealPath(us, curr: widestring): widestring;
begin
  us := curr + us;
  result := ResolveDots(us);
end;

function DrivePresent(const DrivePath: string): Boolean;
var
  i: UINT;
begin
  if (Length(DrivePath) = 0) or (not (DrivePath[1] in ['A'..'Z', 'a'..'z'])) then
  begin
    result := false;
    exit;
  end;
  i := GetDriveType(PChar(DrivePath));
  Result := (i <> DRIVE_NO_ROOT_DIR) and (i <> DRIVE_UNKNOWN);
end;

function DirectoryExists(DirName: string): boolean;
var
  SRec: TSearchRec;
begin
  Result := false;

  if Length(DirName) = 3 then
  begin
    result := DrivePresent(DirName);
    exit;
  end
  else
    if (Length(DirName) > 3) and (AnsiChar(DirName[Length(DirName)]) in ['\',
      '/']) then
    Delete(DirName, Length(DirName), 1);

  if FindFirst(DirName, faAnyFile, SRec) = 0 then
  begin
    if (SRec.Attr and faDirectory) > 0 then
      Result := true;
  end;
  SysUtils.FindClose(SRec);
end;

////////////////////////////////////////////////////////////////////////////////
// TSSHServerThread class

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.OnOpenSubsystem := OnSrvOpenSubsystem;
  FSSHServer.KeyStorage := FHostKeys;
  FSSHServer.AllowedSubsystems.Add('sftp');
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
    ClientSocket.Close;
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;
  if (ClientSocket <> nil) and ClientSocket.Connected then
    ClientSocket.Close;
end;

procedure TSSHServerThread.OnSrvError(Sender: TObject; ErrorCode: integer);
begin
  Log('Error ' + IntToStr(ErrorCode));
end;

procedure TSSHServerThread.OnSrvOpenSubsystem(Sender: TObject; Conn: TElSSHTunnelConnection;
  const Subsystem: string);
var
  Thread: TElSSHSubsystemThread;
begin
  if (lowercase(Subsystem) = 'sftp') then
  begin
    Log('Subsystem (' + Subsystem + ') opened');
    Thread := TElSSHSubsystemThread.Create(TElSFTPSSHSubsystemHandler, Conn, true);
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnOpen := OnSftpOpen;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnCloseHandle := OnSftpCloseHandle;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnCreateDirectory := OnSftpCreateDirectory;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnFindClose := OnSftpFindClose;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnFindFirst := OnSftpFindFirst;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnFindNext := OnSftpFindNext;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnOpenFile := OnSftpOpenFile;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnReadFile := OnSftpReadFile;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnRemove := OnSftpRemove;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnRenameFile := OnSftpRenameFile;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnRequestAbsolutePath := OnSftpRequestAbsolutePath;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnRequestAttributes := OnSftpRequestAttributes;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnRequestAttributes2 := OnSftpRequestAttributes2;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.OnWriteFile := OnSftpWriteFile;
    TElSFTPSSHSubsystemHandler(Thread.Handler).Server.Versions := [sbSFTP0, sbSFTP1, sbSFTP2, sbSFTP3, sbSFTP4, sbSFTP5, sbSFTP6];
    FSubsystemThreads.Add(Thread);
    Thread.Resume;
    ChangeState(ssActive);
  end
  else
    Log('Custom subsystem requested: ' + Subsystem);
end;

procedure TSSHServerThread.DoLog;
begin
  FOnLog(Self, FCurrLogLine);
end;

procedure TSSHServerThread.DoAuthAttempt;
begin
  FCurrBool := false;
  FOnAuthAttempt(Self, FCurrUsername, FCurrAuthType, FCurrBool);
end;

procedure TSSHServerThread.DoAuthPassword;
var
  FCP: boolean;
begin
  FCurrBool := false;
  FOnAuthPassword(Self, FCurrUsername, FCurrPassword, FCurrBool, FCP);
end;

procedure TSSHServerThread.DoConnClosed;
begin
  if Assigned(FOnConnClosed) then
    FOnConnClosed(Self);
end;

procedure TSSHServerThread.DoRefreshInfo;
begin
  if Assigned(FOnRefreshInfo) then
    FOnRefreshInfo(Self);
end;

procedure TSSHServerThread.Log(const S: string);
begin
  if Assigned(FOnLog) then
  begin
    FCurrLogLine := S;
    Synchronize(DoLog);
  end;
end;

function TSSHServerThread.GetTunnelCount: integer;
var
  I: integer;
begin
  Result := FSubsystemThreads.Count;
  for I := 0 to FServerForwardings.Count - 1 do
    Result := Result + TServerSocket(FServerForwardings[I]).Socket.ActiveConnections;
end;

procedure TSSHServerThread.ChangeState(NewState: TSSHServerState);
begin
  FState := NewState;
  Synchronize(DoRefreshInfo);
end;

function TSSHServerThread.FileInfoFromRec(r: WIN32_FIND_DATA): TElSftpFileInfo;
var
  inf: TElSftpFileInfo;
begin
  inf := TElSftpFileInfo.Create;
  if SftpVersion > 3 then
    inf.Name := ConvertToUTF8String(string(r.cFileName))
  else
  begin
    inf.Name := string(r.cFileName);
    inf.LongName := UnixListing(r);
  end;
  inf.Attributes.Size := Int64(r.nFileSizeHigh shl 32) + r.nFileSizeLow;
  if (r.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
  begin
    inf.Attributes.Directory := true;
    inf.Attributes.FileType := ftDirectory;
  end
  else
  begin
    inf.Attributes.Directory := false;
    inf.Attributes.FileType := ftFile;