iehttp3.pas

Delphi7版飞信GreenFetion源码

end;

{procedure TIEHTTP.StopRequest;
begin
  if working_status > 0 then
    flag_request_to_stop := true;
end;}

procedure TIEHTTP.StopRequest(wait: boolean=false);
begin
  if working_status > 0 then
    flag_request_to_stop := true;

  //if wait then
  //  while working_status >0  do
  //    sleep(100);
  //application.processmessages;
end;

procedure TIEHTTP.SetTimeout(const Value: integer);
//var
  //wininet_receive_timeout : Longint;
  //lStructSize : Cardinal;
begin
  //value is in milliseconds
  fTimeout := Value;

  if is_ie6_and_below then exit;

  //ie7 supports timeout
  {wininet_receive_timeout := fTimeout;
  lStructSize := sizeof(wininet_receive_timeout);
  InternetSetOption(nil, INTERNET_OPTION_RECEIVE_TIMEOUT, @wininet_receive_timeout, lStructSize);

  //confirm
  lStructSize := sizeof(wininet_receive_timeout);
  InternetQueryOption(nil, INTERNET_OPTION_RECEIVE_TIMEOUT, @wininet_receive_timeout, lStructSize);}
end;

procedure TIEHTTP.PrepareHeaders1;
begin
  //PrepareHeaders
  if RequestMethod = 'GET' then begin
    //strcat(aURLc2.lpSzUrlPath, aURLc2.lpszExtraInfo); //already has '?'
    aURLc2.lpSzUrlPath := pwidechar( widestring(aURLc2.lpSzUrlPath) + widestring(aURLc2.lpszExtraInfo) );
  end;

  ///12mar03 - add get info before we open the connection
  if FgetStr <> '' then begin

    if pos('?', widestring(aURLc2.lpszUrlPath)) = 0 then
      FgetStr := '?' + FgetStr
    else
      FgetStr := '&' + FgetStr;

    //size1 := length(aURLc2.lpszUrlPath) + length(FgetStr) + 100;
    //getmem(p1, size1);
    //strpcopy(p1, aURLc2.lpszUrlPath);
    //strcat(p1, pchar(FgetStr));

    //todo: enable
    aURLc2.lpszUrlPath := pwidechar( widestring(aURLc2.lpszUrlPath) + WideString(aURLc2.lpszUrlPath) );

    aURLc2.dwUrlPathLength := length( aURLc2.lpszUrlPath );
    FgetStr := '';
  end;
end;
procedure TIEHTTP.PrepareHeaders2;
var
  proxy_auth_header : widestring;
begin
  if RequestMethod = 'GET' then begin
    _lpSzExtraInfo_Bytes := '';
  end;
  if pos('?', _lpSzExtraInfo_Bytes) = 1 then begin
    Delete(_lpSzExtraInfo_Bytes, 1, 1);
  end;

  //23feb03 - add post info after we process the url
  if FpostStr <> '' then begin

    //5aug03: bug fix: aURLc2.lpszExtraInfo cannot be compared to '' (pchar <-> string)
    if widestring(_lpSzExtraInfo_Bytes) <> '' then FpostStr := '&' + FpostStr;

    if RequestMethod='GET' then
      raise exception.create('No poststr allowed in GET method');

    _lpSzExtraInfo_Bytes := _WideStringToUTF8( widestring(aURLc2.lpSzExtraInfo) + widestring(FpostStr) );

    FpostStr := '';
  end;

  //very important for POST
  //---------------------------
  if RequestMethod='POST' then begin
    if content_type='' then
      content_type := 'application/x-www-form-urlencoded';
  end else
    content_type := '';

  if content_type <> '' then
    if pos('Content-Type:', content_type) = 0 then //03apr04
      content_type := 'Content-Type: ' + content_type;

  if content_type <> '' then
    AddHeader(content_type);

  proxy_auth_header := '';
  if proxy_username <> '' then begin
    //InternetSetOption(hSession, INTERNET_OPTION_PROXY_USERNAME,  pchar(proxy_username), strlen(pchar(proxy_username)));
    //InternetSetOption(hSession, INTERNET_OPTION_PROXY_PASSWORD, pchar(proxy_password), strlen(pchar(proxy_password)));
    proxy_auth_header := 'Proxy-Authorization: Basic '
        + B64Encode(proxy_username + ':' + proxy_password);
        //+ '==';
    AddHeader(proxy_auth_header);
  end;

  if request_headers.text <> '' then
    AddHeader(request_headers.text);

  if pos('multipart', WideLowerCase(content_type)) > 0 then
    ConvertToMultiPart;
end;


procedure TIEHTTP.ReadResponse;
var
  read_result : boolean;
  bytesRead: DWORD;
begin
  repeat
    // Get the next chunk
    read_result := InternetReadFile(hFile, @buffer, sizeof(buffer), bytesRead);

    if flag_timeout_occured then begin
      result_ms.clear;
      break;
    end;

    // Pass it along to the stream
    //result_ms.WriteBuffer(buffer^, bytesRead); //if buffer is a PByteArray (pointer)
    result_ms.WriteBuffer(buffer[0], bytesRead); //if buffer is a TByteArray (record)

    //result_ms.Position := 0;
    //result_ms.SaveToFile(ForceUniqueFilename('c:\temp\tiehttp_test\1.txt'));

    inc(bytes_read_total, bytesread);
    inc(debug_total_packets);
    last_packet_read_dt := now;

    CalcTimeoutDatetime;

    //if ie request_to_cancel then free;
    if flag_request_to_stop then break;
    
    if (bytesread > 0) and assigned(FOnPacketRead) then begin
      SetEvent(event_handle);
      if getlasterror <> 0 then
        RaiseLastOSError;
    end;

  until (read_result and (bytesRead = 0)); //Repeat until we get no more data
end;

procedure TIEHTTP.CleanUpConnectionMemory;
begin
  if flag_cleanup_completed then exit;

  flag_cleanup_completed := true; //in order to ensure no double requests will be allowed

  //3apr04
  if multipartpost then
    //aURLc2.lpSzExtraInfo := '';
    _lpSzExtraInfo_Bytes := '';

  // Clean up by closing the handles.
  // According to the docs, we only need to close aHI,
  // which should automatically close the other ones that descend from it
  InternetCloseHandle(hFile);
  InternetCloseHandle(hConnect);
  InternetCloseHandle(hSession);

  //flag_cleanup_completed := true;
end;

procedure TIEHTTP.SetBlockingMode(const Value: boolean);
begin
  fBlockingMode := Value;
end;

function TIEHTTP.GetErrorString(error_code : integer) : widestring;
begin
  case error_code  of
    12001: result := '(Out of handles)';
    12002: result := '(Timeout)';
    12004: result := '(Internal Error)';
    12005: result := '(Invalid URL)';
    12006: result := '(Unrecognized Scheme)';
    12007: result := '(Service Name Not Resolved)';
    12008: result := '(Protocol Not Found)';
    12013: result := '(Incorrect User Name)';
    12014: result := '(Incorrect Password)';
    12015: result := '(Login Failure)';
    12016: result := '(Invalid Operation)';
    12017: result := '(Operation Canceled)';
    12020: result := '(Not Proxy Request)';
    12023: result := '(No Direct Access)';
    12026: result := '(Request Pending)';
    12027: result := '(Incorrect Format)';
    12028: result := '(Item not found)';
    12029: result := '(Cannot connect)';
    12030: result := '(Connection Aborted)';
    12031: result := '(Connection Reset)';
    12033: result := '(Invalid Proxy Request)';
    12034: result := '(Need UI)';
    12035: result := '(Sec Cert Date Invalid)';
    12038: result := '(Sec Cert CN Invalid)';
    12044: result := '(Client Auth Cert Needed)';
    12045: result := '(Invalid CA Cert)';
    12046: result := '(Client Auth Not Setup)';
    12150: result := '(HTTP Header Not Found)';
    12152: result := '(Invalid HTTP Server Response)';
    12153: result := '(Invalid HTTP Header)';
    12154: result := '(Invalid Query Request)';
    12156: result := '(Redirect Failed)';
    12159: result := '(TCP/IP not installed)';
    else result := '(Unknown WININET error # ' + inttostr(error_code) + ')';
  end;
end;

procedure TIEHTTP.AddHeader(s: widestring);
begin
  if extraHeaders <> '' then
    s := #13#10 + s;

  extraHeaders := extraHeaders + s;
end;

procedure TIEHTTP.SetTimeInterval(const Value: Integer);
begin
  fTimerIntervalSeconds := Value;
end;

function TIEHTTP.CheckIEOnline: boolean;
//returns FALSE if internet explorer is set to "work offline"
var
  lpdwBufferLength: DWORD;
  dwFlags : DWord;

  //ci : INTERNET_CONNECTED_INFO;
  //ci_len : integer;
begin
  lpdwBufferLength := 4;

  InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE,
                       @dwFlags, lpdwBufferLength );

  result := (dwFlags = INTERNET_STATE_CONNECTED);

               //INTERNET_STATE_DISCONNECTED_BY_USER
    //dwFlags := dwFlags or INTERNET_OPTION_OFFLINE_MODE;
    //dwFlags := 1;
   // ci.dwConnectedState := INTERNET_STATE_CONNECTED;

    {InternetGoOnline(
     InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, sizeof(ci) );
     InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @dwFlags, lpdwBufferLength );}
end;

function TIEHTTP.GetResponseHeaderIdx(header_name: widestring): integer;
var
  i : integer;
begin
  //remove possible colons and spaces in header name
  header_name := trim(widelowercase(header_name));

  if header_name[length(header_name)] = ':' then
    delete(header_name, length(header_name), 1);

  //header_name := stringreplace(header_name, ':', '', [rfReplaceAll]);
  //header_name := stringreplace(header_name, ' ', '', [rfReplaceAll]);

  result := -1;
  for i := 0 to response_headers.count-1 do begin
    if pos(header_name + ': ', widelowercase(response_headers[i])) = 1 then begin
      result := i;
      exit;
    end;
  end;
end;

function TIEHTTP.GetRequestHeaderIdx(header_name: widestring): integer;
var i : integer;
begin
  //remove possible colons and spaces in header name
  header_name := trim(widelowercase(header_name));

  if header_name[length(header_name)] = ':' then
    delete(header_name, length(header_name), 1);

  //header_name := stringreplace(header_name, ':', '', [rfReplaceAll]);
  //header_name := stringreplace(header_name, ' ', '', [rfReplaceAll]);

  result := -1;
  for i := 0 to request_headers.count-1 do begin
    if pos(header_name + ': ', widelowercase(request_headers[i])) = 1 then begin
      result := i;
      exit;
    end;
  end;
end;

function TIEHTTP.GetResponseHeaderValue(header_name: widestring): widestring;
var
  idx : integer;
  s : widestring;
begin
  s := '';
  idx := GetResponseHeaderIdx(header_name);
  if idx = -1 then exit;

  s := response_headers[idx];
  delete(s, 1, Pos(': ',s)+1);
  Result := s;
end;

function TIEHTTP.GetRequestHeaderValue(header_name: widestring): widestring;
var
  idx : integer;
  s : widestring;
begin
  s := '';
  idx := GetRequestHeaderIdx(header_name);
  if idx = -1 then exit;

  s := request_headers[idx];
  delete(s, 1, Pos(': ',s)+1);
  Result := s;
end;

procedure TIEHTTP.DeleteRequestHeader(header_name: widestring);
var
  idx: integer;
begin
  idx := GetRequestHeaderIdx(header_name);
  if idx = -1 then exit;
  request_headers.Delete(idx);
end;

procedure TIEHTTP.AddRequestHeader(header_name: widestring; value: widestring);
var
  idx: integer;
begin
  header_name := trim(header_name);
  if header_name[length(header_name)] = ':' then
    delete(header_name, length(header_name), 1);

  idx := GetRequestHeaderIdx(header_name);
  if idx > -1 then
    DeleteRequestHeader(header_name);

  request_headers.Add(header_name + ': ' + value);
end;

function TIEHTTP.Canceled : boolean;
begin
  result := error_code = 101;
end;

function TIEHTTP.FileToB64String(filename: widestring): bytestring;
var
  ms : ttntmemorystream;
  s : bytestring;
begin
  ms := ttntmemorystream.create;
  try
    ms.LoadFromFile(filename);
    s := Stream_To_ByteString(ms);
  finally
    ms.free;
  end;

  s := B64Encode(s);

  s := breakuu(s);

  result := s;
end;

end.