serverthread.pas

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

    while i = 1 do
    begin
      delete(p, 1, 1);
      i := pos('/', p);
    end;
    if p = '' then
      break;
    if i > 0 then
    begin
      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;
{  if Length(us) < 1 then
    us := curr
  else
    if us[1] = '/' then // path is root-based, add drive letter
      us := ExtractFileDrive(curr) + us
    else
      if (Length(us) > 1) and (us[2] = ':') then // path is absolute, don't touch it
    //
      else // path is relative
        us := curr + '/' + us;}
  result := ResolveDots(us);
end;

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

procedure TSSHServerThread.OnSftpClose(Sender: TObject);
begin
end;

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

procedure TSSHServerThread.OnSftpCreateDirectory(Sender: TObject;
  const Path: string; Attributes: TElSftpFileAttributes;
  var ErrorCode: integer; var Comment: string);
var
  p: string;
begin
  Comment := '';
  ErrorCode := 0;
  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;

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;

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^);
    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^);
    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);
  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;
begin
  Comment := '';
  ErrorCode := 0;
  i := StatFile(Path);
  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
  i: TElSftpFileInfo;
begin
  Comment := '';
  ErrorCode := 0;
  // TODO
  //i := StatOpenFile(h);
  i.Attributes.CopyTo(Attributes);
end;

procedure TSSHServerThread.OnSftpSetAttributes(Sender: TObject;
  const Path: string; Attributes: TElSftpFileAttributes;
  var ErrorCode: integer; var Comment: string);
begin

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.OnSrvDebug(Sender : TObject; DebugStr : string);
begin
  Log(DebugStr);
end;

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


end.