serverthread.pas

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

unit ServerThread;

interface

uses SysUtils,
  Winsock, ScktComp, SBSSHServer, SBSSHKeyStorage, SBSftpHandler, Classes,
  Windows, SBSSHCommon, SBUtils, SBSftpServer, SBSftpCommon;

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 the approach to keyboard-interactive user authentication used in the demo
    // 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 OnSrvOpenSubsystem(Sender: TObject; Conn: TElSSHTunnelConnection; const Subsystem: string);
    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: WIN32_FIND_DATA): TElSftpFileInfo; virtual;
    function StatFile(name: string): TElSftpFileInfo; virtual;
    function StatOpenFile(Data : pointer): TElSftpFileInfo; virtual;
    procedure OnSftpOpen(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 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;
  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;

{ JPM modifications }
//file attrib constants for Win32 - some are here only for completeness
//Others are here because they may not be defined in Windows.pas
const
  FILE_ATTRIBUTE_READONLY             = $00000001;
  FILE_ATTRIBUTE_HIDDEN               = $00000002;
  FILE_ATTRIBUTE_SYSTEM               = $00000004;
  FILE_ATTRIBUTE_DIRECTORY            = $00000010;
  FILE_ATTRIBUTE_ARCHIVE              = $00000020;
  FILE_ATTRIBUTE_DEVICE               = $00000040;
  FILE_ATTRIBUTE_NORMAL               = $00000080;
  FILE_ATTRIBUTE_TEMPORARY            = $00000100;
  FILE_ATTRIBUTE_SPARSE_FILE          = $00000200;
  FILE_ATTRIBUTE_REPARSE_POINT        = $00000400;
  FILE_ATTRIBUTE_COMPRESSED           = $00000800;
  FILE_ATTRIBUTE_OFFLINE              = $00001000;
  FILE_ATTRIBUTE_NOT_CONTENT_INDEXED  = $00002000;
  FILE_ATTRIBUTE_ENCRYPTED            = $00004000;

// Unfortunately, Win32 attributes do not map cleanly to SFTP v. 5 so
// we have to make some modifications
function Win32AttrToSFTPAttr(const AWinAttr : Cardinal) : Cardinal;
begin
  Result := 0;
  if AWinAttr and FILE_ATTRIBUTE_READONLY > 0 then
  begin
    Result := Result or SSH_FILEXFER_ATTR_FLAGS_READONLY;
  end;
  if AWinAttr and FILE_ATTRIBUTE_SYSTEM > 0 then
  begin
    Result := Result or  SSH_FILEXFER_ATTR_FLAGS_SYSTEM;
  end;
  if AWinAttr and FILE_ATTRIBUTE_HIDDEN > 0 then
  begin
    Result := Result or  SSH_FILEXFER_ATTR_FLAGS_HIDDEN;
  end;
  //I think that Windows NT often is case-insensitive, unlike Linux
  Result := Result or SSH_FILEXFER_ATTR_FLAGS_CASE_INSENSITIVE;
  if AWinAttr and FILE_ATTRIBUTE_ARCHIVE > 0 then
  begin
    Result := Result or SSH_FILEXFER_ATTR_FLAGS_ARCHIVE;
  end;
  if AWinAttr and FILE_ATTRIBUTE_ENCRYPTED > 0 then
  begin
    Result := Result or SSH_FILEXFER_ATTR_FLAGS_ENCRYPTED ;
  end;
  if AWinAttr and FILE_ATTRIBUTE_COMPRESSED > 0 then
  begin
    Result := Result or SSH_FILEXFER_ATTR_FLAGS_COMPRESSED;
  end;
  if AWinAttr and FILE_ATTRIBUTE_SPARSE_FILE > 0 then
  begin
    Result := Result or SSH_FILEXFER_ATTR_FLAGS_SPARSE;
  end;
end;

function FileTimeToTDateTime(const AFileTime: TFileTime): TDateTime;
var
  LDosTime : LongInt;
begin
  if Windows.FileTimeToDosDateTime(AFileTime, LongRec(LDosTime).Hi,
      LongRec(LDosTime).Lo) then
    Result := SysUtils.FileDateToDateTime(LDosTime)
  else
  begin
    Result := 0;
  end;
end;

{ JPM: Addition, it turns out that LongName is being parsed by some programs
such as FTP Voyager.  In this case, it's best to give standard Unix formated
file listings in the longname. }
function IsIn6MonthWindow(const AMDate : TDateTime):Boolean;
//based on http://www.opengroup.org/onlinepubs/007908799/xbd/utilconv.html#usg
//For dates, we display the time only if the date is within 6 monthes of the current
//date.  Otherwise, we send the year.
var
  LCurMonth, LCurDay, LCurYear : Word;  //Now
  LPMonth,  LPYear : Word;
  LMMonth, LMDay, LMYear : Word;
begin
  DecodeDate(Now,LCurYear,LCurMonth,LCurDay);
  DecodeDate(AMDate,LMYear,LMMonth,LMDay);
  if (LCurMonth - 6) < 1 then
  begin
    LPMonth :=  12 + (LCurMonth - 6);
    LPYear := LCurYear - 1;
  end
  else
  begin
    LPMonth := LCurMonth - 6;
    LPYear := LCurYear;
  end;
  if LMYear < LPYear then
  begin
    Result := False;
    Exit;
  end;
  if LMYear = LPYear then
  begin
    Result := (LMMonth >= LPMonth);
    if Result and (LMMonth = LPMonth) then
    begin
      Result := (LMDay >= LCurDay);
      Exit;
    end;
  end
  else
  begin
    Result := True;
  end;
end;

function TwoDigits(const AValue : Word) : String;
begin
  if AValue >9 then
  begin
    Result := IntToStr(AValue);
  end
  else
  begin
    Result := '0'+IntToStr(AValue);
  end;
end;

function UnixListing(ARec : WIN32_FIND_DATA) : String;
var
   LHour, LMin, LSec, LMSec : Word;
      LMonth, LDay, LYear : Word;
   LFileTime : TDateTime;
const
  LMONTHS : array [1..12] of string =
    ('Jan','Feb','Mar',
     'Apr','May','Jun',
     'Jul','Aug','Sep',
     'Oct','Nov','Dec');

begin
  Result := '';
  if (ARec.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
  begin
    //Note that Windows has a slightly different concept of user and ownership.
    //
    //There is a file owner but you can't report it properly in the unix format
    //because Win32 permits spaces in account names while Unix does not.
    //Reporting a username or group name with a space could throw off a Unix list
    //parser.
    if (ARec.dwFileAttributes and FILE_ATTRIBUTE_READONLY) = 0 then
    begin
      Result := 'dr-xr-xr-x   1 user     group    ';
    end
    else
    begin
      Result := 'drwxrwxrwx   1 user     group    ';
   end;
  end
  else
  begin
    Result := '-';
    if (ARec.dwFileAttributes and FILE_ATTRIBUTE_READONLY) = 0 then
    begin
      Result := '-r--r--r--   1 user     group    ';
    end
    else
    begin
      Result := '-rw-rw-rw-   1 user     group    ';
    end;
  end;
  Result := Result + Format('%8d ',
    [Int64(ARec.nFileSizeHigh shl 32) + ARec.nFileSizeLow ]);
  LFileTime := FileTimeToTDateTime(ARec.ftLastWriteTime);
  DecodeDate (LFileTime,LYear,LMonth,LDay);
  Result := Result + LMONTHS[LMonth] + Format(' %2d ',[LDay]);
  if IsIn6MonthWindow(LFileTime) then
  begin
    DecodeTime( LFileTime, LHour,LMin,LSec,LMSec);
    Result := Result + Format('%2s:%2s ',[TwoDigits(LHour),TwoDigits(LMin)]);
  end
  else
    Result := Result + ' '+IntToStr(LYear)+ ' ';
  Result := Result + string(ARec.cFileName);
end;
{ end JPM modifications }

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;

function SizeOfFile(const n: string): int64;
var
  f: TFileStream;
begin
  try
    f := TFileStream.Create(n, fmOpenRead);
    try
      Result := f.Size;
    finally
      f.Free;
    end;
  except
    result := -1;
  end;
end;

function replace(var Str: string; const SourceString, DestString: string): boolean;
var
  i: integer;
begin
  i := pos(SourceString, Str);
  if i = 0 then
  begin
    Result := false;
    exit;
  end;
  Delete(Str, i, Length(SourceString));
  if Length(DestString)>0 then
    Insert(DestString, Str, i);
  Result := true;
end;

function rpos(c: widechar; const s: widestring): integer;
var
  i: integer;
begin
  result := -1;
  i := Length(s);
  while i > 0 do
    if s[i] = c then
    begin
      result := i;
      break;
    end
    else
      dec(i);
end;

function UpDir(const p: widestring): widestring;
var
  i: integer;
begin
  i := rpos('/', p);
  if i < Length(p) then
    result := copy(p, 1, i - 1)
  else
    result := p;
end;

function ResolveDots(p: widestring): widestring;
var
  d, us, hu: widestring;
  i: integer;
begin
  d := '';
  if (Length(p) > 1) and (p[2] = ':') then
  begin
    d := copy(p, 1, 2);
    delete(p, 1, 2);
  end;
  i := pos('/', p);
  us := '';
  while true do
  begin
    while i = 1 do
    begin
      delete(p, 1, 1);
      i := pos('/', p);
    end;
    if p = '' then
      break;
    if i > 0 then
    begin