serverthread.pas

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

  end;
  inf.Attributes.UserRead := true;
  inf.Attributes.GroupRead := true;
  inf.Attributes.OtherRead := true;
  if (r.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
  begin
    inf.Attributes.UserWrite := true;
    inf.Attributes.GroupWrite := true;
    inf.Attributes.OtherWrite := true;
  end;
  { begin JPM modifications }
  inf.Attributes.IncludedAttributes := [saPermissions, saSize];
  //Note that that we do things this way because we want the date in GMT while
  //Borland's TSearchRec itself only has the time converted to local time.
  //You can also get more information from the original Win32_FIND_DATA
  inf.Attributes.MTime := FileTimeToTDateTime(r.ftLastWriteTime);
  inf.Attributes.CTime := FileTimeToTDateTime(r.ftCreationTime);
  inf.Attributes.ATime := FileTimeToTDateTime(r.ftLastAccessTime);
  inf.Attributes.AttribBits :=  Win32AttrToSFTPAttr(R.dwFileAttributes);
  inf.Attributes.IncludedAttributes := inf.Attributes.IncludedAttributes +
    [saATime, saMTime, saCTime,saAttribBits ];
  { end JPM modifications }
  result := inf;
end;

function TSSHServerThread.StatFile(name: string): TElSftpFileInfo;
var
  FindData : WIN32_FIND_DATA;
  H : THandle;
begin
  result := nil;
  if SftpVersion > 3 then
    name := ConvertFromUTF8String(name);
  // converting slashes to backslashes as we are on Win32 system
  while replace(name, '/', '\') do ;
  // removing double slashes
  while replace(name, '\\', '\') do ;
  if CompareText(Name, 'C:\') = 0 then
  begin
    // creating stub for root directory
    FillChar(FindData, SizeOf(FindData), 0);
    FindData.dwFileAttributes := FILE_ATTRIBUTE_DIRECTORY;
    StrPCopy(FindData.cFileName, 'C:\');
    result := FileInfoFromRec(FindData);
  end
  else
  begin
    H := FindFirstFile(PChar(Name), FindData);
    if H <> INVALID_HANDLE_VALUE then
    begin
      result := FileInfoFromRec(FindData);
      FindClose(H);
    end;
  end;
end;

function TSSHServerThread.StatOpenFile(Data : pointer): TElSftpFileInfo;
var
  FileInfo : BY_HANDLE_FILE_INFORMATION;
  FindData : WIN32_FIND_DATA;
begin
  if GetFileInformationByHandle(TFileStream(Data).Handle, FileInfo) then
  begin
    // copying file information to the temporary structure
    FillChar(FindData, SizeOf(FindData), 0);
    FindData.dwFileAttributes := FileInfo.dwFileAttributes;
    Move(FileInfo.ftCreationTime, FindData.ftCreationTime, SizeOf(FindData.ftCreationTime));
    Move(FileInfo.ftLastAccessTime, FindData.ftLastAccessTime, SizeOf(FindData.ftLastAccessTime));
    Move(FileInfo.ftLastWriteTime, FindData.ftLastWriteTime, SizeOf(FindData.ftLastWriteTime));
    FindData.nFileSizeHigh := FileInfo.nFileSizeHigh;
    FindData.nFileSizeLow := FileInfo.nFileSizeLow;
    Result := FileInfoFromRec(FindData);
  end
  else
    Result := nil;
end;

procedure TSSHServerThread.OnSftpOpen(Sender: TObject);
begin
  SftpVersion := TElSFTPServer(Sender).ServerVersion;
end;

procedure TSSHServerThread.OnSftpCloseHandle(Sender: TObject; Data : pointer;
  var ErrorCode: integer; var Comment: string);
begin
  TFileStream(Data).Free;
  ErrorCode := 0;
  Comment := '';
end;

procedure TSSHServerThread.OnSftpCreateDirectory(Sender: TObject;
  const Path: string; Attributes: TElSftpFileAttributes;
  var ErrorCode: integer; var Comment: string);
var
  p: string;
begin
  Comment := '';
  ErrorCode := SSH_FX_OK;
  p := FormRealPath(Path, FCurrentDir);
{$I-}
  MkDir('C:\' + p);
  if IOResult = 0 then
    exit;
{$I+}
  Comment := 'Can''t create directory';
  ErrorCode := SSH_FX_FAILURE;
end;

procedure TSSHServerThread.OnSftpFindClose(Sender: TObject; Data : pointer;
  var ErrorCode: integer; var Comment: string);
begin
  SysUtils.FindClose(PSearchRec(Data)^);
  Dispose(PSearchRec(Data)); 
  ErrorCode := SSH_ERROR_OK;
end;

procedure TSSHServerThread.DoAuthPublicKey;
begin
  FCurrBool := false;
  FOnAuthPublicKey(Self, FCurrUsername, FCurrKey, FCurrBool);
end;

procedure TSSHServerThread.DoFurtherAuthNeeded;
begin
  FCurrBool := false;
  FOnFurtherAuthNeeded(Self, FCurrUsername, FCurrBool);
  FSSHServer.AuthenticationTypes := FSSHServer.AuthenticationTypes and not AuthAllTypes;
end;

procedure TSSHServerThread.OnSftpFindFirst(Sender: TObject; const Path: string;
  var Data : pointer; Info: TElSftpFileInfo; var ErrorCode: integer; var Comment: string);
var
  i: TElSftpFileInfo;
  p: string;
  Rec : PSearchRec;
begin
  p := FormRealPath(Path, FCurrentDir);
  if not DirectoryExists('C:' + p) then
  begin
    Comment := 'Invalid directory path';
    if SftpVersion < 3 then
      ErrorCode := SSH_FX_FAILURE
    else
      ErrorCode := SSH_FX_NO_SUCH_FILE;
    exit;
  end;
  Comment := '';

  New(Rec);
  ErrorCode := FindFirst('C:' + p + '\*.*', faAnyFile, Rec^);
  if ErrorCode = 0 then
  begin
    i := FileInfoFromRec(Rec^.FindData);
    i.CopyTo(Info);
    i.Free;
    ErrorCode := 0;
    Data := Rec;
    Comment := '';
  end
  else
  begin
    ErrorCode := SSH_FX_EOF;
    Comment := 'No files';
  end;
end;

procedure TSSHServerThread.OnSftpFindNext(Sender: TObject; Data : pointer;
  Info: TElSftpFileInfo; var ErrorCode: integer; var Comment: string);
var
  i: TElSftpFileInfo;
  Rec : PSearchRec;
begin
  Rec := Data;
  ErrorCode := FindNext(Rec^);
  if ErrorCode = 0 then
  begin
    i := FileInfoFromRec(Rec^.FindData);
    i.CopyTo(Info);
    i.Free;
    ErrorCode := 0;
    Comment := '';
  end
  else
  begin
    ErrorCode := SSH_FX_EOF;
    Comment := 'No files';
  end;
end;

procedure TSSHServerThread.OnSftpOpenFile(Sender: TObject; const Path: string;
  Modes: TSBSftpFileOpenModes; Access: TSBSftpFileOpenAccess;
  DesiredAccess: Cardinal; Attributes: TElSftpFileAttributes; var Data: pointer;
  var ErrorCode: integer; var Comment: string);
var
  p: string;
  md: integer;
begin
  p := FormRealPath(Path, FCurrentDir);
  p := 'C:\' + p;
  md := 0;

  if ((fmCreate in Modes) and (fmTruncate in Modes)) then
    md := Classes.fmCreate
  else
    if ((fmCreate in Modes) and (fmExcl in Modes)) then
    begin
      if FileExists(p) then
      begin
        Comment := 'Can''t open file';
        if SftpVersion > 2 then
          ErrorCode := SSH_FX_FILE_ALREADY_EXISTS
        else
          ErrorCode := SSH_FX_FAILURE;
      end
      else
        md := Classes.fmCreate;
    end
    else
      if (fmCreate in Modes) then
      begin
        if FileExists(p) then
          md := fmOpenReadWrite
        else
          md := Classes.fmCreate;
      end
      else
        if (fmAppend in Modes) then
          md := fmOpenReadWrite
        else
          if ((fmRead in Modes) and (fmWrite in Modes)) then
            md := fmOpenReadWrite
          else
            if (fmRead in Modes) then
              md := fmOpenRead
            else
              if (fmWrite in Modes) then
                md := fmOpenWrite
              else
                md := fmOpenReadWrite;
  try
    Data := TFileStream.Create(p, md);
    Comment := '';
    ErrorCode := SSH_FX_OK;
  except
    Comment := 'Can''t open file';
    ErrorCode := SSH_FX_FAILURE;
    exit;
  end;
  if (fmAppend in Modes) then
    TFileStream(Data).Position := TFileStream(Data).Size;
end;

procedure TSSHServerThread.OnSftpReadFile(Sender: TObject;
  Data : pointer; Offset: Int64; Buffer: Pointer; Count: integer;
  var Read, ErrorCode: integer; var Comment: string);
begin
  Comment := '';
  ErrorCode := 0;
  if Offset >= TFileStream(Data).Size then
  begin
    Comment := 'Reading beyond end of file';
    ErrorCode := SSH_FX_EOF;
    exit;
  end;
  TFileStream(Data).Position := Offset;
  try
    Read := TFileStream(Data).Read(Buffer^, Count);
  except
    on E : Exception do
    begin
      Comment := 'File read error: ' + E.Message;
      ErrorCode := SSH_FX_FAILURE;
      Read := 0;
    end;
  end;
end;

procedure TSSHServerThread.OnSftpRemove(Sender: TObject;
  const Path: string; var ErrorCode: integer; var Comment: string);
var
  p: string;
begin
  p := FormRealPath(Path, FCurrentDir);
  p := 'C:\' + p;
  ErrorCode := 0;
  Comment := '';
  if DirectoryExists(p) then
  begin
    if RemoveDir(p) then
      exit;
    ErrorCode := SSH_FX_FAILURE;
    Comment := 'Can''t remove directory. May be it isn''t empty?';
  end
  else
    if FileExists(p) then
    begin
      if SysUtils.DeleteFile(p) then
        exit;
      ErrorCode := SSH_FX_FAILURE;
      Comment := 'Can''t remove file';
    end
    else
    begin
      if SftpVersion < 3 then
        ErrorCode := SSH_FX_FAILURE
      else
        ErrorCode := SSH_FX_NO_SUCH_PATH;
      Comment := 'Invalid file or directory path';
    end;
end;

procedure TSSHServerThread.OnSftpRenameFile(Sender: TObject; const OldPath,
  NewPath: string; Flags : TSBSftpRenameFlags; var ErrorCode: integer; var Comment: string);
var
  p, p2: string;
begin
  p := 'C:\' + FormRealPath(OldPath, FCurrentDir);
  p2 := 'C:\' + FormRealPath(NewPath, FCurrentDir);
  Comment := '';
  ErrorCode := 0;
  if not RenameFile(p, p2) then
  begin
    Comment := 'Can''t rename file or directory';
    ErrorCode := SSH_FX_FAILURE;
  end;
end;

procedure TSSHServerThread.OnSftpRequestAbsolutePath(Sender: TObject;
  const Path: string; var AbsolutePath: string; Control : TSBSftpRealpathControl;
  ComposePath : TStringList; var ErrorCode: integer;
  var Comment: string);
begin
  Comment := '';
  ErrorCode := 0;
  AbsolutePath := FormRealPath(Path, FCurrentDir);
end;

procedure TSSHServerThread.OnSftpRequestAttributes(Sender: TObject;
  const Path: string; FollowSymLinks: boolean;
  Attributes: TElSftpFileAttributes; var ErrorCode: integer;
  var Comment: string);
var
  i: TElSftpFileInfo;
  LPath : String;
begin
  Comment := '';
  ErrorCode := 0;
  // JPM modifications
  LPath :=  'C:\' + FormRealPath(Path, FCurrentDir);
  i := StatFile(LPath);
  // end modifications
  if (i <> nil) then
  begin
    i.Attributes.CopyTo(Attributes);
    i.Free;
  end
  else
  begin
    ErrorCode := SSH_ERROR_NO_SUCH_FILE;
    Comment := 'No such file or directory';
  end;
end;

procedure TSSHServerThread.OnSftpRequestAttributes2(Sender: TObject;
  Data: pointer; Attributes: TElSftpFileAttributes;
  var ErrorCode: integer; var Comment: string);
var
  Info : TElSftpFileInfo;
begin
  Comment := '';
  ErrorCode := 0;
  Info := StatOpenFile(Data);
  if Info <> nil then
  begin
    Info.Attributes.CopyTo(Attributes);
    FreeAndNil(Info);
  end
  else
  begin
    ErrorCode := SSH_ERROR_INVALID_HANDLE;
    Comment := 'Invalid handle';
  end;
end;

procedure TSSHServerThread.OnSftpWriteFile(Sender: TObject;
  Data : pointer; Offset: Int64; Buffer: Pointer; Count: integer;
  var ErrorCode: integer; var Comment: string);
var
  l: integer;
begin
  Comment := '';
  ErrorCode := 0;
  TFileStream(Data).Position := Offset;
  l := TFileStream(Data).Write(Buffer^, Count);
  if l <> Count then
  begin
    Comment := 'File write error';
    ErrorCode := SSH_FX_FAILURE;
  end;
end;

procedure TSSHServerThread.OnSrvFurtherAuthNeeded(Sender: TObject; const
    Username: string; var Needed: boolean);
begin
  if Assigned(FOnFurtherAuthNeeded) then
  begin
    FCurrUsername := Username;
    FUsername := Username;
    Synchronize(DoFurtherAuthNeeded);
    Needed := FCurrBool;
  end
  else
    Needed := false;
end;

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

end.