Unit für TWebbrowser Cache (Ingore Cache...)

[dtrace]

Hallo zusammen,
ich bin gerade dabei einen Browser zu schreiben, der den Cache ignoriert (um die Privatsphäre) zu schützen. Man könnte den Cache zwar leeren, aber dann ist alles weg.

Nun habe ich eine Unit geschrieben, die eingebunden werden muss. Der Cache wird nun total ignoriert bis auf 2 Merkmale wo ich nicht weiter komme. Es wird noch der Cookie gespeichert und in die besuchten Seiten werden gespeichert. Ich habe alles schon probiert, komme jetzt aber echt nicht mehr weiter.

Hier der Sourcecode der Unit:

Delphi-Quellcode:

unit uNSPass;

interface

uses
  Windows, SysUtils, UrlMon, ActiveX, Classes, ComObj, Axctrls, ComServ,
  WinInet, Dialogs;

const
  CLSID_Passthrough: TGUID  = '{A8BF46F5-7291-44F8-8DC3-6C1FAEB3C3E0}';
  CLSID_HttpProtocol: TGUID = '{79EAC9E2-BAF9-11CE-8C82-00AA004BA90B}';

type
  TNSPassthrough = class(TComObject, IInternetProtocol,
    IInternetBindInfo, IInternetProtocolSink)
  private
    FDefaultSink: IInternetProtocol;
    FProtSink: IInternetProtocolSink;
    FBindInfo: IInternetBindInfo;
  public
    procedure Initialize(); override;
    function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;

    {IInternetProtocolRoot}
    function Start(szUrl: LPCWSTR; OIProtSink: IInternetProtocolSink;
      OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;
    function Continue(const ProtocolData: TProtocolData): HResult; stdcall;
    function Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;
    function Terminate(dwOptions: DWORD): HResult; stdcall;
    function Suspend: HResult; stdcall;
    function Resume: HResult; stdcall;
    {IInternetProtocol}
    function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
    function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
    function LockRequest(dwOptions: DWORD): HResult; stdcall;
    function UnlockRequest: HResult; stdcall;
    {IInternetBindInfo}
    function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
    function GetBindString(ulStringType: ULONG; wzStr: POLEStrArray; cEl: ULONG;
      var cElFetched: ULONG): HResult; stdcall;
    {IInternetProtocolSink}
    function Switch(const ProtocolData: TProtocolData): HResult; stdcall;
    function ReportProgress(ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; stdcall;
    function ReportData(grfBSCF: DWORD; ulProgress, ulProgressMax: ULONG): HResult; stdcall;
    function ReportResult(hrResult: HResult; dwError: DWORD; szResult: LPCWSTR): HResult; stdcall;
  end;


implementation

procedure TNSPassthrough.Initialize();
begin
  inherited;
  
  FDefaultSink := nil;
end;

function TNSPassthrough.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := inherited ObjQueryInterface(IID, Obj);

  if (Result = E_NOINTERFACE) and (Assigned(FDefaultSink)) then
    Result := FDefaultSink.QueryInterface(IID, Obj);
end;

{IInternetProtocolRoot}
function TNSPassthrough.Start(szUrl: LPCWSTR; OIProtSink: IInternetProtocolSink; OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;
begin
  if (FDefaultSink = nil) then
    OleCheck(CoCreateInstance(CLSID_HttpProtocol, nil, CLSCTX_INPROC_SERVER, IUnknown, FDefaultSink));

  FBindInfo := OIBindInfo;
  FProtSink := OIProtSink;

  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocolRoot).Start(szUrl, Self, Self, grfPI, dwReserved)
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.Continue(const ProtocolData: TProtocolData): HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocolRoot).Continue(ProtocolData)
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocolRoot).Abort(hrReason, dwOptions)
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.Terminate(dwOptions: DWORD): HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocolRoot).Terminate(dwOptions)
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.Suspend: HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocolRoot).Suspend()
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.Resume: HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocolRoot).Resume()
  else
    Result := E_NOTIMPL;
end;

{IInternetProtocol}
function TNSPassthrough.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocol).Read(pv, cb, cbRead)
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocol).Seek(dlibMove, dwOrigin, libNewPosition)
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.LockRequest(dwOptions: DWORD): HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocol).LockRequest(dwOptions)
  else
    Result := E_NOTIMPL;
end;

function TNSPassthrough.UnlockRequest: HResult; stdcall;
begin
  if (Assigned(FDefaultSink)) then
    Result := (FDefaultSink as IInternetProtocol).UnlockRequest()
  else
    Result := E_NOTIMPL;
end;

{IInternetBindInfo}
function TNSPassthrough.GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
begin
  Result := FBindInfo.GetBindInfo(grfBINDF, bindinfo);

  //set the flags here
  grfBINDF := grfBINDF or BINDF_NOWRITECACHE or BINDF_NEEDFILE or BINDF_PRAGMA_NO_CACHE;  //-----> hier wird der Cache ignoriert
end;

function TNSPassthrough.GetBindString(ulStringType: ULONG; wzStr: POLEStrArray; cEl: ULONG; var cElFetched: ULONG): HResult; stdcall;
begin
  Result := FBindInfo.GetBindString(ulStringType, wzStr, cEl, cElFetched);
end;

{IInternetProtocolSink}
function TNSPassthrough.Switch(const ProtocolData: TProtocolData): HResult; stdcall;
begin
  Result := FProtSink.Switch(ProtocolData);
end;

function TNSPassthrough.ReportProgress(ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; stdcall;
begin
  case (ulStatusCode) of
    BINDSTATUS_COOKIE_SENT,
    BINDSTATUS_COOKIE_SUPPRESSED,
    BINDSTATUS_COOKIE_STATE_DOWNGRADE,
    BINDSTATUS_COOKIE_STATE_UNKNOWN,
    BINDSTATUS_SESSION_COOKIE_RECEIVED,
    BINDSTATUS_COOKIE_STATE_ACCEPT,
    BINDSTATUS_COOKIE_STATE_LEASH,
    BINDSTATUS_COOKIE_STATE_REJECT,
    BINDSTATUS_PERSISTENT_COOKIE_RECEIVED:

    Result := S_FALSE;


    else
      Result := FProtSink.ReportProgress(ulStatusCode, szStatusText);
  end;

end;

function TNSPassthrough.ReportData(grfBSCF: DWORD; ulProgress, ulProgressMax: ULONG): HResult; stdcall;
begin

  Result := FProtSink.ReportData(grfBSCF, ulProgress, ulProgressMax);

end;

function TNSPassthrough.ReportResult(hrResult: HResult; dwError: DWORD; szResult: LPCWSTR): HResult; stdcall;
begin
  Result := FProtSink.ReportResult(hrResult, dwError, szResult);
end;


initialization
  CoInitialize(nil);
  OleInitialize(nil);
  TComObjectFactory.Create(ComServer, TNSPassthrough, CLSID_Passthrough, 'TNSPassthrough', 'TNSPassthrough', ciMultiInstance);

finalization
  CoUninitialize();
  OleUninitialize();

end.

So wird die Unit eingebunden:
Im OnCreate Ereignis des Mainforms

Delphi-Quellcode:

procedure TFMain.FormCreate(Sender: TObject);
var VerlaufAnzahl, I: Integer;
    Hotk, hotk2: longbool;
begin
  CoGetClassObject(CLSID_Passthrough, CLSCTX_SERVER, nil, IClassFactory, Factory);
  CoInternetGetSession(0, InternetSession, 0);
  InternetSession.RegisterNameSpace(Factory, CLSID_Passthrough, 'http', 0, nil, 0);
  InternetSession.RegisterNameSpace(Factory, CLSID_Passthrough, 'https', 0, nil, 0);
end;

und die Initialisierung am Ende des Mainforms vor "end."

Delphi-Quellcode:

initialization
  CoInitialize(nil);
  OleInitialize(nil);

finalization
  CoUninitialize();
  OleUninitialize();

end.

Im Projekt Source müsst Ihr die Unit ComServ einbinden. So sieht mein ProjectSource aus:

Delphi-Quellcode:

program Test;

uses
  Forms,
  UMain in 'UMain.pas' {FMain},
  ComServ;

{$R *.res}

begin
  Application.Initialize;
  ComServer.UIInteractive := False;
  Application.Title := 'Test';
  Application.CreateForm(TFMain, FMain);
  Application.Run;
end.

Ich habe versucht die "Function ReportProgress" so zu modifizieren, dass Cookies ignoriert werden...aber kein Erfolg

Delphi-Quellcode:

function TNSPassthrough.ReportProgress(ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; stdcall;
begin
  case (ulStatusCode) of
    BINDSTATUS_COOKIE_SENT,
    BINDSTATUS_COOKIE_SUPPRESSED,
    BINDSTATUS_COOKIE_STATE_DOWNGRADE,
    BINDSTATUS_COOKIE_STATE_UNKNOWN,
    BINDSTATUS_SESSION_COOKIE_RECEIVED,
    BINDSTATUS_COOKIE_STATE_ACCEPT,
    BINDSTATUS_COOKIE_STATE_LEASH,
    BINDSTATUS_COOKIE_STATE_REJECT,
    BINDSTATUS_PERSISTENT_COOKIE_RECEIVED:

    Result := S_FALSE;


    else
      Result := FProtSink.ReportProgress(ulStatusCode, szStatusText);
  end;

end;

Ich hoffe Ihr habt eine Idee....

[dtrace]

Wenn Ihr nun die TWebbrowser oder TEmbeddedWB Komponente nutzt, wird der Cache komplett ignoriert, bis auf Cookies und den Visited Verlauf ....

[dtrace]

Niemand eine Idee?

[hinnack]

Hi,

vielleicht musst du IHttpNegotiate überschreiben und
aus aus HttpNegotiate.OnResponse alle Set-Cookie: aaa=bbb;path=/ aus szResponseHeaders entfernen

hast du mit FileMon mal geschaut? macht der auch Schreib-Operationen? oder nur Lesen?

Bei deiner Cache-Ignore Funktion wundert mich, das das funktioniert...
zumal du BINDSTATUS_CACHEFILENAMEAVAILABLE nicht unterdrückst

Hast du auch immer noch das Phänomen, das IE dennoch ein QUERY_INFORMATION auf seiner Index.dat macht?

Ich brauche das ganze nicht wegen der Privatsphäre, sonder wegen der langsamen Performance mancher Virenscanner.
Wir haben eine Web-Anwendung im IE laufen und Performance-Einbusse von über 200%. Den Temporary-Internet-Folder
deswegen jedoch auszulassen halte ich für fahrlässig :-)

[dtrace]

[quote="hinnack"]Hi,

vielleicht musst du IHttpNegotiate überschreiben und
aus aus HttpNegotiate.OnResponse alle Set-Cookie: aaa=bbb;path=/ aus szResponseHeaders entfernen
quote]

Hmm... hast du das mal ausprobiert?
Ich werde das auch mal ausprobieren...