iehttp3.pas

Delphi7版飞信GreenFetion源码

    //wininet_receive_timeout := 0;
    //InternetSetOption(nil, INTERNET_OPTION_RECEIVE_TIMEOUT, @wininet_receive_timeout, sizeof(wininet_receive_timeout));

    // Make a connection to that host, raising an exception if no connection}
        //    aHConnect := InternetConnect(aHI, aURLc.lpSzHostName,
        //               INTERNET_INVALID_PORT_NUMBER, nil, nil,
        //               INTERNET_SERVICE_HTTP, 0, 0);
    context := 0;
    hConnect := InternetConnectW(hSession, aURLc2.lpSzHostName,
                aURLc2.nPort{INTERNET_DEFAULT_HTTPS_PORT}, aURLc2.lpszUserName, aURLc2.lpszPassword,
               INTERNET_SERVICE_HTTP, 0, context);

    if (hConnect = nil) then begin
      //raise exception.createFmt('Could not connect to server %s', [aURLc2.lpSzHostName]);
      error_msg := format('Could not connect to server %s', [aURLc2.lpSzHostName]);
      exit;
    end;

    // Open a reqest to get ready to GET data, raising an exception if not successful
    //    aHFile := HTTPOpenRequest(aHConnect, PChar(sMethod), aURLc.lpSzUrlPath, HTTP_VERSION, nil,
    //      nil, INTERNET_FLAG_DONT_CACHE, 0);
    if aURLc2.nPort = 443 then
      dwflags := INTERNET_FLAG_SECURE
              or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
              or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID
              or SECURITY_FLAG_IGNORE_UNKNOWN_CA //avoid 12045 -> todo: not working here
      //dwflags := SECURITY_INTERNET_MASK
      //dwflags := 0
    else
      dwflags := 0;

    dwFlags := dwFlags or INTERNET_FLAG_RELOAD;

    PrepareHeaders1;

    setlasterror(0);
    hFile := HTTPOpenRequestW(hConnect, PWideChar( RequestMethod ),
                             aURLc2.lpSzUrlPath, HTTP_VERSION, nil, nil, dwflags, context);
    dwError := getlasterror;
    if dwError <> 0 then begin
      if dwError in [183,122] then
        //sometimes we may receive these errors
        //183: cannot create a file when that file already exists (win98/d6)
        //122: the data area passed to a system call is too small
        dwError := 0
      else begin
        //RaiseLastWin32Error; //no exceptions in the thread
        error := dwerror; //will be handled outside thread
        exit;
        //raise exception.create('error #' + inttostr(dwError));
      end;
    end;

    //if getlasterror <> 0 then RaiseLastWin32Error;

    if (hFile = nil) then begin
      //raise exception.create('Could not open HTTP request');
      error_msg := 'Could not open HTTP request';
      exit;
    end;

  {lStructSize := sizeof(DWORD);
  InternetQueryOption(nil, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, lStructSize);
  //showmessage(inttostr(dwflags)); //SECURITY_FLAG_SSL3
        dwflags := INTERNET_FLAG_SECURE
              or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
              or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID
              or SECURITY_FLAG_IGNORE_UNKNOWN_CA
              or SECURITY_FLAG_SSL3
              or SECURITY_FLAG_SSL
              or SECURITY_FLAG_IGNORE_WRONG_USAGE
              or SECURITY_FLAG_IGNORE_REVOCATION;
  InternetSetOption(hFile, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, sizeof(dwFlags) );}

    // Add any extra headers to the request, raising an exception if not successful
    //   if not HTTPAddRequestHeaders(aHFile, PChar(s), length(s), HTTP_ADDREQ_FLAG_ADD) then
    //     raise(EHTTPAddReqError.create('Could not add HTTP request header'));

    // Send the request, raising an exception if not successful
    //    if not HTTPSendRequest(hFile, nil, 0, aURLc.lpSzExtraInfo, aURLc.dwExtraInfoLength) then begin
    //      dwError := getlasterror;

    PrepareHeaders2;

    //-------------------------
    //Connection Attempt
    //-------------------------

    if (error_msg <> '') or (error <> 0) then exit;

    //_lpSzExtraInfo_Bytes is used to send binary data
    if not HTTPSendRequestW(hFile, pwidechar( extraHeaders ), length(extraHeaders),
                                   //aURLc2.lpSzExtraInfo, aURLc2.dwExtraInfoLength) then begin
                                   //_lpSzExtraInfo_Ansi, _dwExtraInfoLength)) then begin
                                   pansichar(_lpSzExtraInfo_Bytes), length(_lpSzExtraInfo_Bytes)) then begin
      dwError := getlasterror;
      //if not HTTPSendRequestEx(hFile, extraHeaders, extraHeadersLength, aURLc2.lpSzExtraInfo, aURLc2.dwExtraInfoLength) then begin
      //  dwError := getlasterror;

      //if (dwError <> 0) then begin
      //showmessage(GetErrorString(dwError));
      //don't raise exception here because this procedure is called in a thread
      //RaiseLastWin32Error;
      //RaiseLastOSError;
      //end;

      if dwError = 12045 then begin
        //try again if Certificate is invalid

        {     x := nil;
        InternetErrorDlg(GetDesktopWindow(),
                           aHFile,
                           ERROR_INTERNET_INVALID_CA,
                           FLAGS_ERROR_UI_FILTER_FOR_ERRORS or
                           FLAGS_ERROR_UI_FLAGS_GENERATE_DATA or
                           FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS,
                           x);}

        InternetQueryOptionW( hFile, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, lpdwBufferLength);

        dwFlags := dwFlags or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
        InternetSetOptionW( hFile, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, sizeof(dwFlags) );

        //verify: InternetQueryOption(hFile, INTERNET_OPTION_SECURITY_FLAGS,
        //         @dwFlags, lpdwBufferLength);
        {    hFile := HTTPOpenRequest(hConnect, PChar(sMethod),
        aURLc.lpSzUrlPath, HTTP_VERSION, nil, nil, dwflags, context);
        dwError := getlasterror;
        if dwError <> 0 then RaiseLastWin32Error;}

        //this incorrectly reports error 2 : file not found..., so do not handle the error
        if not HTTPSendRequestW(hFile, pwidechar(extraHeaders), length(extraHeaders),
                                 //aURLc2.lpSzExtraInfo, aURLc2.dwExtraInfoLength)
                                 //_lpSzExtraInfo_Ansi, _dwExtraInfoLength)
                                 pansichar(_lpSzExtraInfo_Bytes), length(_lpSzExtraInfo_Bytes))
        then ;
        dwError := getlasterror;
        //if getlasterror <> 0 then RaiseLastWin32Error;
      end; //retry invalid certificate
    end;

    if dwError > 0 then exit;

    dwBufLen := sizeof(ContentSize);
    ContentSize := 0;
    dwIndex := 0;
    HttpQueryInfoW(hFile, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, @ContentSize, dwBufLen, dwIndex );
    if ContentSize=0 then ContentSize:=1; //avoid division by 0
    //bytes_total := ContentSize;

    bytes_read_total := 0;

    ReadCookiesAndHeaders(hFile);

    //asp.net (aspx) disabled content-length even if it is set manually
    //WRONG, content length is being removed from iis-gzip compression filter
    //in such case content is always compressed
    if ContentSize <= 1 then begin
      ContentSize_custom := GetResponseHeaderValue('Custom-Content-Length');
      if (ContentSize_custom <> '') and (ContentSize_custom<>'0') then
        ContentSize := strtoint(ContentSize_custom);
    end;

    {
http://groups.google.com/groups?hl=en&lr=&ie=UTF-8&oe=UTF-8&safe=off&th=e9372deb72b03c8d&rnum=15
InternetReadFile does not work Async.
It blocks until a least some data are read,
and you have no way to stop it other than killing the thread.
Using ReadFileEx, you can use the callback function so you don't need
a thread, and you can stop the call whenever you want, thus respecting timeout values.
}

    CalcTimeoutDatetime;

    //
    // Loop to read the content from the URL in chunks
    ReadResponse;

    //if (not flag_request_to_stop) and (not flag_timeout_occured) then begin
    //end;

    //moved before read response because we may need Custom-Content-Length
    //ReadCookiesAndHeaders(hFile);

  finally
    CleanUpConnectionMemory;
    error := dwError;

  end;

end;

procedure TIEHTTP.CrackURL;
var
  s1, s2, s3 : array[1..INTERNET_MAX_PATH_LENGTH] of widechar;
begin
  //Clear the structure
  FillChar(aURLC2, sizeOf(TURLComponents), 0);
  aURLC2.lpszUrlPath := nil;
  aURLC2.lpszExtraInfo := nil;

  aURLC2.dwStructSize := sizeOf(TURLComponents);
  aURLC2.lpSzExtraInfo := @s1[1];
  aURLC2.dwExtraInfoLength := INTERNET_MAX_PATH_LENGTH;
  aURLC2.lpSzHostName := @s2[1];
  aURLC2.dwHostNameLength := INTERNET_MAX_PATH_LENGTH;
  aURLC2.lpszUrlPath := @s3[1];
  aURLC2.dwUrlPathLength := INTERNET_MAX_PATH_LENGTH;

  _lpSzExtraInfo_Bytes := '';

  if not InternetCrackUrlW( PWideChar(furl), 0, ICU_ESCAPE, aURLC2) then begin
    //raise exception.createFmt('TIE: Invalid URL. Error - %d = ', [GetLastError, SysErrorMessage(GetLastError)]);
    error_msg := format('tiehttp: Invalid URL. Error - %d = %s', [GetLastError, SysErrorMessage(GetLastError)]);
    exit;
  end;

  if widestring(aurlc2.lpszUrlPath) = '' then begin
    error_msg := 'tiehttp: Empty URL';
    exit;
  end;

  //remove only on post
  //if pos('?', aURLc.lpSzExtraInfo) = 1 then begin
  //   aURLc.lpSzExtraInfo := pchar(copy(aURLc.lpSzExtraInfo,2, aURLc.dwExtraInfoLength));
  //   dec(aURLc.dwExtraInfoLength);
  // end;

  //todo: add urldecode?
  _lpSzExtraInfo_Bytes := _WideStringToUTF8(aURLC2.lpszExtraInfo);
  if pos('+', _lpSzExtraInfo_Bytes) > 0 then  //v=1+2 even if passed as 1%2B2, crack url set's it to 1+2
    _lpSzExtraInfo_Bytes := {ansi}stringreplace(_lpSzExtraInfo_Bytes, '+', '%2B', [rfReplaceAll] );

  if (widestring(aURLC2.lpszUserName)='') and (username <> '') then begin
    aURLC2.lpszUserName := pwidechar(Username);
    aURLC2.lpszPassword := pwidechar(Password);
  end;
end;

procedure TIEHTTP.ExecuteURL(url: widestring);
begin
  SetURL(url);
  Execute;
end;

procedure TIEHTTP.Execute;
//var ie_thread : ttimeout;
var
  msg : widestring;
  tmp_dt : tdatetime;
  s : bytestring;
  //response_charset : widestring;
begin
  if working_status <> 0 then begin
    if MessageDlg('Request is in progress (iehttp). Override and continue?', mtConfirmation, [mbOK, mbCancel], 0) <> mrOK then
      exit;
    //raise exception.create('tiehttp: Cannot reuse TIE, while processing request');
    //exit;
  end;
  working_status := 1;

  error_code := 0;
  error := 0;
  error_msg := '';
  bytes_read_total := 0;
  contentSize := 0;

  if furl = '' then raise exception.create('TIEHTTP: no url in execute method');

  try
    result_sl.Clear;
    result_ms.Clear;

    //CrackURL; //crack occurs every time we set the url
    //CrackURL; //FIXED there is a bug that causes the script path to disappear if we progressivly call the same execute command.
    //ProcessReadRequest;

    CalcTimeoutDatetime;
    flag_timeout_occured := false;

    flag_request_to_stop := false;
    flag_cleanup_completed := false;

    last_packet_read_dt := now;
    last_packet_processed_dt := now;

    //create event first
    //create event must be in the same thread as the waitforsingleobject
    //event_handle := CreateEvent(nil, False, False, nil);
    event_handle := CreateEvent(nil, TRUE, False, nil); //2nd param=true means we can reset the event by calling resetEvent

    ie_thread_finished := false;
    //ie_thread_ready := false;
    ie_thread := ttimeout.create(true);
    ttimeout(ie_thread).owner_ie := self;
    ie_thread.Resume;

    //waitForSingleObjectEx(0,infinite,true);

    {$IFDEF tie_debug} LogStr('cp1'); {$endif}
    repeat
      //event_handle := CreateEvent(nil, False, False, nil);

      //check timeout every 500 milliseconds,
      //if request processed before 500ms, WaitForSingleObject will continue
      {$IFDEF tie_debug} LogStr('cp1a'); {$endif}
      try
      {$IFDEF tie_debug} LogStr('about to call WaitForSingleObject. Event handle =' + inttostr(event_handle) + ' .thread done=' + booltostr(ie_thread_finished)); {$endif}

        //mainwait
        //flag_WaitForSingleObject := true;
        WaitForSingleObject(event_handle, 500); //if wfso = WAIT_TIMEOUT then
        //flag_WaitForSingleObject := false;
        ResetEvent(event_handle); //set to non-signeled, resetEvent cancels setEvent
        //CloseHandle( event_handle ); //don't close handle, since event is reusable

        {$IFDEF tie_debug} LogStr('ok. Event handle =' + inttostr(event_handle) + ' .thread done=' + booltostr(ie_thread_finished)); {$endif}
      except
        {$IFDEF tie_debug} LogStr('tiehttp: CANNOT call WaitForSingleObject. Event handle =' + inttostr(event_handle) + ' .thread done=' + booltostr(ie_thread_finished)); {$endif}
        raise exception.create('CANNOT call WaitForSingleObject. Event handle =' + inttostr(event_handle) + ' .thread done=' + booltostr(ie_thread_finished));
        break;
      end;
      {$IFDEF tie_debug} LogStr('cp2'); {$endif}

      //use copy to avoid inconcistency of last_packet_read_dt value, since it may change in thread
      tmp_dt := last_packet_read_dt;
      if assigned(FOnPacketRead) and (tmp_dt>last_packet_processed_dt) then begin
        last_packet_processed_dt := tmp_dt;

        //if not flag_process_onpacketread then
        //  showmessage('managed to process lost packet');

        inc(debug_total_packet_events);
        FOnPacketRead(self);

        //after processing because thread will wait for this flag to continue after successfully processing packet
        //flag_process_onpacketread := false;
      end;

      if assigned(FOnTimer) and (fTimerIntervalSeconds>0)
                            and (last_timer_procesed_dt + (fTimerIntervalSeconds/SecsPerDay) < now) then
      begin
        last_timer_procesed_dt := now;

        //if not flag_process_onpacketread then
        //  showmessage('managed to process lost packet');

        inc(debug_total_timer_events);
        FOnTimer(self);

        //after processing because thread will wait for this flag to continue after successfully processing packet
        //flag_process_onpacketread := false;
      end;


      if not fBlockingMode then //allows user to cancel request
        application.processmessages;

      {$IFDEF tie_debug} LogStr('cp3'); {$endif}

      if (flag_request_to_stop) then begin
        self.working_status := 0; //12mar05
        InternetCloseHandle( hSession );
        //request_to_stop := false;
        result_ms.Clear;
        //msg := '[error 101: canceled by user]';
        //result_ms.Write(pchar(msg)[1], length(msg));
        msg := '';
        error_code := 101; //canceled
        break; //thread may never finish, but there is nothing we can do
      end;
      {$IFDEF tie_debug} LogStr('cp4'); {$ENDIF}

      if ((fTimeout>0) and (now > timeout_datetime)) then begin
        InternetCloseHandle( hSession );
        flag_timeout_occured := true;
        result_ms.Clear;
        result_ms.position := 0;
        //08feb08
        //msg := '[error 100: tiehttp timeout expired]';
        //result_ms.Write(pchar(msg)[1], length(msg));
        //result_ms.WriteBuffer(msg[1], length(msg));
        msg := '';
        error_code := 100; //timeout
        break; //thread may never finish, but there is nothing we can do
      end;
      {$IFDEF tie_debug} LogStr('cp5'); {$endif}
    until ie_thread_finished;
    //if (ie_thread.finished) and (ie_thread <> nil) then
    //  raise exception.create('thread finished but is not nil');

    CloseHandle( event_handle ); //caused crash because we were closing in the thread