WBCustomPostDataSender

unit WBCustomPostDataSender;

interface

uses  EmbeddedWB, Classes, SysUtils, Variants, StrUtils, WideStrUtils, md5hash;

type
  TCustomPostParam = record
    name : string;
    value : string;

    filename : string;
    content_type : string;
  end;

  TCustomPostDataSender = class
  private
    WB : TEmbeddedWB;

    FParams : array of TCustomPostParam;
    FURL : string;
    FContentType : string;
    FBoundary : string;

    procedure GenerateNewBoundary();
    function CheckBoundary(str : string):boolean;
    function FGetHeader():string;
    function StringToVariantArray(str: string): OleVariant;
    procedure CheckUTF8(var str: string);
  public
    constructor Create(Browser : TEmbeddedWB); overload;

    procedure Clear();
    function POST():integer;
    function Count():integer;

    function AddParam(name, value : string; content_type : string = ''; filename : string = ''):integer;
    procedure AddTextFile(name, path : string);
    procedure AddFile(name, path, file_content_type : string);

    property url : string read FURL write FURL;
    property content_type : string read FContentType write FContentType;
  end;

implementation

{ TCustomPostDataSender }


function TCustomPostDataSender.AddParam(name, value: string; content_type : string = ''; filename : string = ''):integer;
var
  h : integer;
begin
  SetLength(FParams, Count() + 1);
  h := high(FParams);

  FParams[h].name := name;
  FParams[h].value := value;
  FParams[h].content_type := content_type;
  FParams[h].filename := filename;

  CheckBoundary(name + ' ' + value + ' ' + content_type);
  result := h;
end;

procedure TCustomPostDataSender.AddFile(name, path, file_content_type: string);
var
  s : TStringStream;
  buf : string;
begin
  if not FileExists(path) then exit;
  file_content_type := Trim(file_content_type);
  if file_content_type = '' then file_content_type := 'text/plain';

  s := TStringStream.Create;
  try
    s.LoadFromFile(path);
    buf := s.DataString;
    if Pos('text', LowerCase(file_content_type)) = 1 then CheckUTF8(buf);
    AddParam(name, buf, file_content_type, ExtractFileName(path));
  finally
    s.Free;
  end;
end;

procedure TCustomPostDataSender.AddTextFile(name, path: string);
begin
  if not FileExists(path) then exit;

  if LowerCase(ExtractFileExt(path)) = '.xml'
    then AddFile(name, path, 'text/xml')
    else AddFile(name, path, 'text/plain');
end;

function TCustomPostDataSender.CheckBoundary(str: string):boolean;
begin
  result := pos(LowerCase(FBoundary), LowerCase(str)) <> 0;
  if result then GenerateNewBoundary();
end;

procedure TCustomPostDataSender.Clear;
begin
  SetLength(FParams, 0);
  FURL := '';
  FContentType := '';
  GenerateNewBoundary();
end;

function TCustomPostDataSender.Count: integer;
begin
  Result := Length(FParams);
end;

constructor TCustomPostDataSender.Create(Browser: TEmbeddedWB);
begin
  WB := Browser;
  Clear();
end;

function TCustomPostDataSender.FGetHeader: string;
begin
  if FContentType = '' then FContentType := 'multipart/form-data';
  Result := 'Content-Type: ' + FContentType + '; boundary=' + FBoundary;

  Result := Result + sLineBreak + 'Referer: ' + WB.LocationURL;
end;

procedure TCustomPostDataSender.GenerateNewBoundary;
var
  i : integer;
begin
  FBoundary := MD5(DateTimeToStr(now));
  delete(FBoundary, 14, MaxInt);
  FBoundary := '---------------------------' + FBoundary;

  for i := 0 to Count - 1 do
  if CheckBoundary(FParams[i].name + ' ' + FParams[i].value + ' ' + FParams[i].content_type) then break;
end;

function TCustomPostDataSender.POST():integer;
var
  sURL, sFlags, sTargetFrame, sPostData, sHeaders : OleVariant;

  i : integer;
  buf : string;
begin
  Result := 1;
  if FURL = '' then exit;

  try
    sURL := FURL;
    sFlags := 64;   // Значение этого флага мне не известно, но браузер использует всегда именно такое
    sHeaders := FGetHeader();

    buf := '';
    for i := 0 to Count() - 1 do
    begin
      if i = 0 then buf := buf + '--' + FBoundary + sLineBreak;

      buf := buf + 'Content-Disposition: form-data; name="'+ FParams[i].name +'"';

      // Если файл
      if FParams[i].filename <> ''
        then buf := buf + '; filename="'+ FParams[i].filename +'"' + sLineBreak + 'Content-Type: ' + FParams[i].content_type;
      buf := buf + sLineBreak + sLineBreak;

      buf := buf + FParams[i].value + sLineBreak;
      buf := buf + '--' + FBoundary;

      if i = Count() - 1 then buf := buf + '--';
      buf := buf + sLineBreak;
    end;

    sPostData := StringToVariantArray(buf);
    WB.Navigate2(sURL, sFlags, sTargetFrame, sPostData, sHeaders);
    Clear();
    Result := 0;
  except
    Result := 999;
  end;
end;

procedure TCustomPostDataSender.CheckUTF8(var str:string);
var
  del_bom : boolean;
begin
  if IsUTF8String(RawByteString(str)) then
  begin
    del_bom := HasUTF8BOM(RawByteString(str));
    str := Utf8ToUnicodeString(RawByteString(str));
    if del_bom then Delete(str, 1, 1);
  end;
end;

function TCustomPostDataSender.StringToVariantArray(str: string): OleVariant;
var
  pLocked: Pointer;
  tmp : TMemoryStream;
  RBuf : RawByteString;
begin
  tmp := TMemoryStream.Create;
  try
    //RBuf := StrEncodeUtf8(str);
    RBuf := UTF8Encode(str);
    tmp.WriteBuffer(RBuf[1], length(RBuf));

    Result := VarArrayCreate([0, tmp.Size-1], varByte);
    pLocked := VarArrayLock(Result);
    try
      tmp.Position := 0;
      tmp.ReadBuffer(pLocked^, tmp.Size);
    finally
      VarArrayUnlock(Result);
    end;
  finally
    tmp.Free;
  end;
end;

end.