ReSQL.ru
     
powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Delphi [игнор отключен] [закрыт для гостей] / Отменить HttpSendRequest в WinInet
17 сообщений из 17, страница 1 из 1
Отменить HttpSendRequest в WinInet
    #39921933
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
Часть кода опустил для читабельности, но суть, думаю ясна. Вызываю загрузку страницы через WinInet, на форму вешаю кнопку отмены. InternetCloseHandle(FHttpRequest) не решает проблемы. Где-то читал, что отменять запросы можно только в асинхронном соединении, но при установки ключа INTERNET_FLAG_ASYNC у меня вообще не выгружает страницу...
Код: pascal
1.
2.
3.
4.
5.
6.
7.
FHttpSession:= InternetOpen(PChar(FClientName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
FHttpConnect:= InternetConnect(FHttpSession, PChar(hostname), Flags_connection, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
FHttpRequest:= HttpOpenRequest(FHttpConnect, PChar(FMethod), PChar(script), HTTP_VERSION, nil, nil, Flags_Request, 0);
HttpSendRequest(httpRequest, nil, 0, nil, 0); // Вот тут подвисает
InternetCloseHandle(FHttpRequest);
InternetCloseHandle(FHttpConnect);
InternetCloseHandle(FHttpSession);
...
Рейтинг: 0 / 0
03.02.2020, 17:32
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39921993
Фотография _Vasilisk_
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
_Vasilisk_
Участник
aford
при установки ключа INTERNET_FLAG_ASYNC у меня вообще не выгружает страницу...
Код будет?
...
Рейтинг: 0 / 0
03.02.2020, 18:58
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922129
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
_Vasilisk_
Код будет?

Вот код:
 

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
unit UnitWinInet;

interface

uses
  System.SysUtils, System.Types, WinInet, Winapi.Windows;

type

  TWinInet = class
    private
      FHWND: THandle; // Хэндл вызывающего приложения
      FClientName, // Имя клиента
      FParam, // параметры запроса (которые после ?)
      FMethod, // GET, POST и др.
      FType_Access, // mime type и проч, если установлен в '', то используется по умолчанию
      FLogin, // логин
      FPass: string; // пароль
      FPostData: boolean; //True - передача параметров запроса через post data, False - через строку запроса
      procedure SetMethod(AMethod: string);
    public
      property HWND: THandle read FHWND write FHWND;
      property ClientName: string read FClientName write FClientName;
      property Param: string read FParam write FParam;
      property Method: string read FMethod write SetMethod;
      property Type_Access: string read FType_Access write FType_Access;
      property Login: string read FLogin write FLogin;
      property Pass: string read FPass write FPass;
      property PostData: boolean read FPostData write FPostData;
      function GetHTTP(AURL: string): AnsiString;
      constructor Create(AHWND: THandle);
  end;

implementation


constructor TWinInet.Create(AHWND: THandle);
begin
  FHWND:= AHWND;
  FClientName:= 'WinInet';
  FMethod:= 'GET';
  FType_Access:= 'Content-Type: application/x-www-form-urlenDELPHId' + #13#10 +
                   'Content-Length:' + IntToStr(length(FParam));
  FPostData:= False;
end;

procedure TWinInet.SetMethod(AMethod: string);
begin
  FMethod:= UpperCase(AMethod);
end;

function TWinInet.GetHTTP(AURL: string): AnsiString;

  function GetHostName(AUrl: string): string;
  var
    s: string;
  begin // Имя хоста
    if Pos('https://', AUrl) > 0 then
      s:= 'https://'
    else
      if Pos('http://', AUrl) > 0 then
        s:= 'http://'
      else
        s:= EmptyStr;
    if s <> EmptyStr then
      if Pos(s, AUrl) > 0 then
        Delete(AUrl, 1, Length(s));
    if Pos('/', AUrl) > 0 then
      SetLength(AUrl, Pos('/', AUrl) - 1);
    Result:= AUrl;
  end;

  function GetScriptName(AUrl, AHostname: string): string;
  begin // URL после имени хоста
    Result:= EmptyStr;
    Delete(AUrl, 1, Pos(AHostname, AUrl) + Length(AHostname));
    Result:= AUrl;
  end;

  procedure SetFlags(AUrl: string; out Flags_connection, Flags_Request: Cardinal);
  begin // Определяем https или http
    if Pos('https', AUrl) > 0 then
    begin
      Flags_connection:= INTERNET_DEFAULT_HTTPS_PORT;
      Flags_Request:= INTERNET_FLAG_RELOAD
                   or INTERNET_FLAG_NO_CACHE_WRITE
                   or INTERNET_FLAG_SECURE
                   or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
                   or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID
                   or INTERNET_FLAG_KEEP_CONNECTION
    end else
      begin
        Flags_connection:= INTERNET_DEFAULT_HTTP_PORT;
        Flags_Request:= INTERNET_FLAG_RELOAD
                     or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
                     or INTERNET_FLAG_NO_CACHE_WRITE
                     or INTERNET_FLAG_PRAGMA_NOCACHE
                     or INTERNET_FLAG_KEEP_CONNECTION;
      end;
  end;

  function GetResponseHeader(const hRequest: Pointer): string;
  var
    dwSize, Index: DWORD;
    szBuff: array [0..1024] of Char;
  begin // Возвращает заголовок ответа сервера в виде строк с CR/LF
    Index:= 0;
    dwSize:= SizeOf(szBuff);
    HttpQueryInfo(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, @szBuff, dwSize, Index);
    Result:= PChar(@szBuff);
  end;

  function GetStatus(const hRequest: Pointer): DWORD;
  var
    dwSize, dwStatus, Index: DWORD;
  begin // Возвращает заголовок ответа сервера в виде строк с CR/LF
    // Возвращает код статуса HTTP из заголовка ответа
    Index:= 0;
    dwSize:= SizeOf(dwStatus);
    HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @dwStatus, dwSize, Index);
    Result:= dwStatus;
  end;

  function AddSecurityFlags(httpReq: Pointer): Boolean;
  var
    dwSize, dwFlags: DWORD;
  begin
    Result:= False;
    dwSize:= SizeOf(dwFlags);     // Get the current security flags
    if (InternetQueryOption(httpReq, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, dwSize)) then
    begin // Add desired flags
       dwFlags:= dwFlags
         or SECURITY_FLAG_IGNORE_UNKNOWN_CA
         or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
         or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID
         or SECURITY_FLAG_IGNORE_REVOCATION;
       Result:= (InternetSetOption(httpReq,
              INTERNET_OPTION_SECURITY_FLAGS,
              @dwFlags,
              dwSize));
    end
  end;

  function SendRequest(httpRequest: Pointer; AType_Access, AParam: string): boolean;
  begin
    case FPostData of
      False: Result:= HttpSendRequest(httpRequest, nil, 0, nil, 0);
      True: Result:= HttpSendRequest(httpRequest, PChar(AType_Access), Length(AType_Access), PChar(AParam), Length(AParam));
    end;
  end;

var
  httpSession, httpConnect, httpRequest: HINTERNET;
  bytes, b, pos: Cardinal;
  hostname, script: string;
  Flags_connection, Flags_Request: Cardinal;
  DlgError: DWORD;
begin
  Result:= EmptyAnsiStr;
  hostname:= GetHostName(AURL); // имя хоста
  script:= GetScriptName(AURL, hostname); // скрипт
  // установка доп. параметров
  if not FPostData then // если передаем параметры через строку запроса, то
    if FParam <> EmptyStr then // дополняем скрипт
      if script[Length(script)] = '?' then
        script:= script + FParam
      else
        script:= script + '?' + FParam;
  try
    SetFlags(AURL, Flags_connection, Flags_Request); // Устанавливаем флаги (http или https)
    // Открываем сессию (инициализируем WinInet)
    httpSession:= InternetOpen(PChar(FClientName), 
                         INTERNET_OPEN_TYPE_PRECONFIG, 
                         nil, nil, 
                         0); // Если вместо 0 указываю тут INTERNET_FLAG_ASYNC - ничего не выгружает, ОШИБКА 0 The operation completed successfully
    if Assigned(httpSession) then // Проверяем хэндл
    try // Открываем соединение
      httpConnect:= InternetConnect(httpSession, PChar(hostname), Flags_connection, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
      if Assigned(httpConnect) then // Проверяем хэндл
      try // Открываем запрос (передаем остаток URL (скрипт GetScriptName) в ф-ю HttpOpenRequest под параметром lpszObjectName)
        httpRequest:= HttpOpenRequest(httpConnect, PChar(FMethod), PChar(script), HTTP_VERSION, nil, nil, Flags_Request, 0);
        if Assigned(httpRequest) then
        try
          AddSecurityFlags(httpRequest);
          SendRequest(httpRequest, FType_Access, FParam); // Отправляем запрос
          if GetStatus(httpRequest) = HTTP_STATUS_DENIED then
          begin // Если необходима авторизация
            if FLogin <> EmptyStr then
            begin
              InternetSetOption(httpRequest, INTERNET_OPTION_USERNAME, PChar(FLogin), SizeOf(FLogin));
              InternetSetOption(httpRequest, INTERNET_OPTION_PASSWORD, PChar(FPass), SizeOf(FPass));
            end
              else
              begin
                DlgError:= InternetErrorDlg(FHWND, httpRequest,
                   ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED,
                   FLAGS_ERROR_UI_FILTER_FOR_ERRORS
                or FLAGS_ERROR_UI_FLAGS_GENERATE_DATA
                   //or FLAGS_ERROR_UI_SERIALIZE_DIALOGS
                or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS,
                   PPointer(nil)^ );
                if DlgError = 0 then
                begin
                  Result:= AnsiString('Доступ запрещен! Ввод учетных данных отменен.'
                   + sLineBreak + SysErrorMessage(GetLastError));
                  Exit;
                end;
              end;
            SendRequest(httpRequest, FType_Access, FParam);
          end;
          if GetStatus(httpRequest) = HTTP_STATUS_OK then
          begin
            pos:= 1;
            b:= 1;
            while b > 0 do
            begin // Если количество данных 0 - генерируем исключение
              if not InternetQueryDataAvailable(httpRequest, bytes, 0, 0) then
                Result:= AnsiString('Сервер не вернул данные! (функция InternetQueryDataAvailable)' + sLineBreak + SysErrorMessage(GetLastError));
              SetLength(Result, Cardinal(Length(Result)) + bytes);
              // Получаем данные с сервера
              InternetReadFile(httpRequest, @Result[Pos], bytes, b);
              Inc(Pos, b);
            end;
            Result:= Result + AnsiString(sLineBreak + SysErrorMessage(GetLastError));
          end else
            Result:= AnsiString('ОШИБКА ' + IntToStr(GetStatus(httpRequest)) + sLineBreak + SysErrorMessage(GetLastError));
        finally
          InternetCloseHandle(httpRequest); // закрываем запрос
        end else
          Result:= AnsiString('Ошибка формирования запроса (функция HttpOpenRequest)' + sLineBreak + SysErrorMessage(GetLastError));
      finally
        InternetCloseHandle(httpConnect); // закрываем соединение
      end else
        Result:= AnsiString('Ошибка открытия сессии (функция InternetConnect)' + sLineBreak + SysErrorMessage(GetLastError));
    finally
      InternetCloseHandle(httpSession); // закрываем сессию
    end else
      Result:= AnsiString('Отсутствует подключение к сети (функция InternetOpen)' + sLineBreak + SysErrorMessage(GetLastError));
  except
    On E: Exception do
      Result:= AnsiString('Ошибка! ' + E.ClassName + ': ' + E.Message);
  end;
end;

end.


...
Рейтинг: 0 / 0
04.02.2020, 08:47
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922154
Василий 2
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Василий 2
Участник
aford

Код: pascal
1.
2.
  begin // Определяем https или http
    if Pos('https', AUrl) > 0 then



На урле http://httpsrules.org сломается
Ну и 4-кратный finally это не круто. Все можно упаковать в один
...
Рейтинг: 0 / 0
04.02.2020, 10:21
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922160
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
Василий 2, спасибо, поправлю, когда будет время. Но проблему я так и не решил.. асинхронный вызов не работает, точнее я не представляю как его сделать. InternetCloseHandle вроде срабатывает, но не на корпоративном сайте, там как-будто HttpSendRequest ждем ответа сервера, а потом только закрывается.
Делаю так. В проекте 3 модуля: главный, модуль потока и что-то вроде обертки над wininet, которую привел выше. На главной форме на кнопку вешаю такой обработчик:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
procedure TFrmTesting.Button1Click(Sender: TObject);
begin
  if Assigned(ThreadWinInetReq) then
  begin
    ThreadWinInetReq.StopThread;
    ThreadWinInetReq.Terminate;
  end;
end;


Событие StopThread:
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
procedure TThreadWinInetReq.StopThread;
begin
  if Assigned(FClient) then
  begin
    FClient.Stop:= True;
    FClient.CancelRequest;
  end;
  Terminate;
end;


Событие CancelRequest:
Код: pascal
1.
2.
3.
4.
5.
6.
procedure TWinInet.CancelRequest;
begin
  InternetCloseHandle(FHttpRequest);
  InternetCloseHandle(FHttpConnect);
  InternetCloseHandle(FHttpSession);
end;
...
Рейтинг: 0 / 0
04.02.2020, 10:50
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922180
Zelius
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Zelius
Участник
aford,

мало просто ASYNC флаг повесить, надо еще дорабатывать код - вот тут пример правда на сях
...
Рейтинг: 0 / 0
04.02.2020, 11:28
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922309
Фотография _Vasilisk_
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
_Vasilisk_
Участник
aford
Вот код:
Ну т.е. вы надеялись, что этот код будет работать если просто в одном месте поменять 0 на INTERNET_FLAG_ASYNC? Как бы название константы намекает, что выполнение запросов становится асинхронным и код, рассчитанный на последовательное выполнение работать не будет автоматически.
...
Рейтинг: 0 / 0
04.02.2020, 14:40
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922366
Фотография Dmitry Arefiev
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dmitry Arefiev
Участник
Что значит - не решает проблемы ?
...
Рейтинг: 0 / 0
04.02.2020, 16:11
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922378
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
Dmitry Arefiev, запрос не закрывается.
Вот что сейчас есть, не пойму как правильно запустить InternetReadFileEx
Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
 procedure StatusCallback(hInet: HINTERNET; Context: DWORD_PTR; Status: DWORD; pInformation: Pointer;
    InfoLength: DWORD); stdcall;
  var
    s: string;
  begin
    case Status of
      INTERNET_STATUS_CLOSING_CONNECTION: s := 'Closing the connection to the server';
      INTERNET_STATUS_CONNECTED_TO_SERVER: s := 'Successfully connected to the socket address: ';
      INTERNET_STATUS_CONNECTING_TO_SERVER: s := 'Connecting to the socket address';
      INTERNET_STATUS_CONNECTION_CLOSED: s := 'Successfully closed the connection to the server';
      INTERNET_STATUS_CTL_RESPONSE_RECEIVED: s := 'Not implemented';
      INTERNET_STATUS_HANDLE_CLOSING: s := 'This handle value has been terminated';
      INTERNET_STATUS_HANDLE_CREATED: s := 'InternetConnect has created the new handle';
      INTERNET_STATUS_INTERMEDIATE_RESPONSE: s :=
      'Received an intermediate (100 level) status code message from the server';
      INTERNET_STATUS_NAME_RESOLVED: s := 'Successfully found the IP address: ' + PChar(pInformation);
      INTERNET_STATUS_PREFETCH: s := 'Not implemented';
      INTERNET_STATUS_RECEIVING_RESPONSE: s := 'Waiting for the server to respond to a request ';
      INTERNET_STATUS_REDIRECT: s := 'HTTP request is about to automatically redirect the request ' +
        PChar(pInformation);
      INTERNET_STATUS_REQUEST_COMPLETE:
        begin
          s:= 'An asynchronous operation has been completed';
          completed:= True;
        end;
      INTERNET_STATUS_REQUEST_SENT: s := 'Successfully sent the information request to the server: ' +
        IntToStr(Integer(pInformation)) + ' Byte';
      INTERNET_STATUS_RESOLVING_NAME: s := 'Looking up the IP address: ' + PChar(pInformation);
      INTERNET_STATUS_SENDING_REQUEST: s := 'Sending the information request to the server.';
      INTERNET_STATUS_RESPONSE_RECEIVED:
        begin
          s:= 'Successfully received a response from the server: ' + IntToStr(Integer(pInformation)) + ' Byte';
          completed:= True;
        end;
      INTERNET_STATUS_STATE_CHANGE:
        begin
          s := 'Moved between a secure (HTTPS) and a nonsecure (HTTP) site.';
          case DWORD(pInformation) of
            INTERNET_STATE_CONNECTED: s := s + #13#10 + 'Connected state. Mutually exclusive with disconnected state.';
            INTERNET_STATE_DISCONNECTED: s := s + #13#10 +
              'Disconnected state. No network connection could be established.';
            INTERNET_STATE_DISCONNECTED_BY_USER: s := s + #13#10 + 'Disconnected by user request.';
            INTERNET_STATE_IDLE: s := s + #13#10 + 'No network requests are being made by Windows Internet.';
            INTERNET_STATE_BUSY: s := s + #13#10 + 'Network requests are being made by Windows Internet.';
          end;
        end;
    end;
    //ShowMessage(s);
  end;
...
FHttpSession:= InternetOpen(PChar(FClientName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, INTERNET_FLAG_ASYNC);
Status:= InternetSetStatusCallback(FHttpSession,INTERNET_STATUS_CALLBACK(@StatusCallback));
if NativeInt(Status) = INTERNET_INVALID_STATUS_CALLBACK then
begin
  Result:= AnsiString('Callback function is not valid');
  Exit;
end;
FHttpConnect:= InternetConnect(FHttpSession, PChar(hostname), Flags_connection, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
FHttpRequest:= HttpOpenRequest(FHttpConnect, PChar(FMethod), PChar(script), HTTP_VERSION, nil, nil, Flags_Request, 1);
HttpSendRequest(httpRequest, nil, 0, nil, 0);
while True do
begin
Sleep(100);
if FStop then
begin
  Result:= AnsiString('Остановлено');
  Exit;
end;
if completed then
  break;
end;
if GetStatus(FHttpRequest) = HTTP_STATUS_OK then
begin
    pos:= 1;
    b:= 1;
    while (b > 0) and (FStop = False) do
    begin // Если количество данных 0 - генерируем исключение
      //Sleep(50);
      if not InternetQueryDataAvailable(FHttpRequest, bytes, 0, 0) then
        Result:= AnsiString('Сервер не вернул данные! (функция InternetQueryDataAvailable)' + sLineBreak + SysErrorMessage(GetLastError));
      SetLength(Result, Cardinal(Length(Result)) + bytes);
      // Получаем данные с сервера
      //InternetReadFile(FHttpRequest, @Result[Pos], bytes, b);
      InternetReadFileEx(FHttpRequest, @Result[Pos], bytes, b);
      Inc(Pos, b);
    end;
    Result:= Result + AnsiString(sLineBreak + SysErrorMessage(GetLastError));    
end;


Теперь нужно посчитать ib.dwBufferLength, правильно? Только как это сделать...
...
Рейтинг: 0 / 0
04.02.2020, 16:31
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922647
Фотография Dmitry Arefiev
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dmitry Arefiev
Участник
авторDmitry Arefiev, запрос не закрывается
В WinHttp что бы заработало, пришлось дополнительно к закрытию хэндлов в колбэке проверять флаг остановки
...
Рейтинг: 0 / 0
05.02.2020, 10:13
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922678
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
Dmitry Arefiev, сделал с колбэками. Вроде работает в асинхронном режиме, но, бывает, что загружает со 2-го раза страницу, где требуется авторизация. И +не выскакивает окно ввода логина с паролем, если не передавать функции данные авторизации
 

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
unit UnitWinInet;

interface

uses
  System.SysUtils, System.Types, WinInet, Winapi.Windows;

type

  TWinInet = class
    private
      FHWND: THandle; // Хэндл вызывающего приложения
      FClientName, // Имя клиента
      FParam, // параметры запроса (которые после ?)
      FMethod, // GET, POST и др.
      FType_Access, // mime type и проч, если установлен в '', то используется по умолчанию
      FLogin, // логин
      FPass: string; // пароль
      FPostData: boolean; //True - передача параметров запроса через post data, False - через строку запроса
      FStop: boolean; // вспомогательная переменная отв. за остановку скачки
      FHttpSession, FHttpConnect, FHttpRequest: HINTERNET;
      FAsync: Boolean;
      procedure SetMethod(AMethod: string);
    public
      property HWND: THandle read FHWND write FHWND;
      property ClientName: string read FClientName write FClientName;
      property Param: string read FParam write FParam;
      property Method: string read FMethod write SetMethod;
      property Type_Access: string read FType_Access write FType_Access;
      property Login: string read FLogin write FLogin;
      property Pass: string read FPass write FPass;
      property PostData: boolean read FPostData write FPostData;
      property Async: boolean read FAsync write FAsync;
      function GetHTTP(AURL: string): AnsiString;
      procedure CancelRequest;
      constructor Create(AHWND: THandle);
  end;

implementation

uses
  Vcl.Dialogs, System.Classes, UnitTesting;
var
  completed, BOK: boolean;

procedure TWinInet.CancelRequest;
begin
  FStop:= True;
  InternetCloseHandle(FHttpRequest);
  InternetCloseHandle(FHttpConnect);
  InternetCloseHandle(FHttpSession);
  InternetSetOption(nil, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0);
end;

constructor TWinInet.Create(AHWND: THandle);
begin
  FHWND:= AHWND;
  FClientName:= 'WinInet';
  FMethod:= 'GET';
  FType_Access:= 'Content-Type: application/x-www-form-urlenDELPHId' + #13#10 +
                   'Content-Length:' + IntToStr(length(FParam));
  FPostData:= False;
  FAsync:= True;
end;

procedure TWinInet.SetMethod(AMethod: string);
begin
  FMethod:= UpperCase(AMethod);
end;

function TWinInet.GetHTTP(AURL: string): AnsiString;

  function GetHostName(AUrl: string): string;
  var
    s: string;
  begin // Имя хоста
    if Pos('https://', AUrl) > 0 then
      s:= 'https://'
    else
      if Pos('http://', AUrl) > 0 then
        s:= 'http://'
      else
        s:= EmptyStr;
    if s <> EmptyStr then
      if Pos(s, AUrl) > 0 then
        Delete(AUrl, 1, Length(s));
    if Pos('/', AUrl) > 0 then
      SetLength(AUrl, Pos('/', AUrl) - 1);
    Result:= AUrl;
  end;

  function GetScriptName(AUrl, AHostname: string): string;
  begin // URL после имени хоста
    Result:= EmptyStr;
    Delete(AUrl, 1, Pos(AHostname, AUrl) + Length(AHostname));
    Result:= AUrl;
  end;

  procedure SetFlags(AUrl: string; out Flags_connection, Flags_Request: Cardinal);
  begin // Определяем https или http
    if Pos('https://', AUrl) > 0 then
    begin
      Flags_connection:= INTERNET_DEFAULT_HTTPS_PORT;
      Flags_Request:= INTERNET_FLAG_RELOAD
                   or INTERNET_FLAG_NO_CACHE_WRITE
                   or INTERNET_FLAG_SECURE
                   or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
                   or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID
                   //or INTERNET_FLAG_KEEP_CONNECTION
    end else
      begin
        Flags_connection:= INTERNET_DEFAULT_HTTP_PORT;
        Flags_Request:= INTERNET_FLAG_RELOAD
                     or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
                     or INTERNET_FLAG_NO_CACHE_WRITE
                     or INTERNET_FLAG_PRAGMA_NOCACHE
                     or INTERNET_FLAG_KEEP_CONNECTION;
      end;
  end;

  function GetResponseHeader(const hRequest: Pointer): string;
  var
    dwSize, Index: DWORD;
    szBuff: array [0..1024] of Char;
  begin // Возвращает заголовок ответа сервера в виде строк с CR/LF
    Index:= 0;
    dwSize:= SizeOf(szBuff);
    HttpQueryInfo(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, @szBuff, dwSize, Index);
    Result:= PChar(@szBuff);
  end;

  function GetStatus(const hRequest: Pointer): DWORD;
  var
    dwSize, dwStatus, Index: DWORD;
  begin // Возвращает заголовок ответа сервера в виде строк с CR/LF
    // Возвращает код статуса HTTP из заголовка ответа
    Index:= 0;
    dwSize:= SizeOf(dwStatus);
    HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @dwStatus, dwSize, Index);
    Result:= dwStatus;
  end;

  function AddSecurityFlags(httpReq: Pointer): Boolean;
  var
    dwSize, dwFlags: DWORD;
  begin
    Result:= False;
    dwSize:= SizeOf(dwFlags);     // Get the current security flags
    if (InternetQueryOption(httpReq, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, dwSize)) then
    begin // Add desired flags
       dwFlags:= dwFlags
         or SECURITY_FLAG_IGNORE_UNKNOWN_CA
         or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
         or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID
         or SECURITY_FLAG_IGNORE_REVOCATION;
       Result:= (InternetSetOption(httpReq,
              INTERNET_OPTION_SECURITY_FLAGS,
              @dwFlags,
              dwSize));
    end
  end;

  function SendRequest(httpRequest: Pointer; AType_Access, AParam: string): boolean;
  begin
    Result:= False;
    if (FStop = False) then
      case FPostData of
        False: Result:= HttpSendRequest(httpRequest, nil, 0, nil, 0);
        True: Result:= HttpSendRequest(httpRequest, PChar(AType_Access), Length(AType_Access), PChar(AParam), Length(AParam));
      end;
  end;

  procedure StatusCallback(hInet: HINTERNET; Context: DWORD_PTR; Status: DWORD; pInformation: Pointer;
    InfoLength: DWORD); stdcall;
  var
    s: string;
  begin
    case Status of
      INTERNET_STATUS_CLOSING_CONNECTION: s:= 'Closing the connection to the server';
      INTERNET_STATUS_CONNECTED_TO_SERVER: s:= 'Successfully connected to the socket address: ';
      INTERNET_STATUS_CONNECTING_TO_SERVER: s:= 'Connecting to the socket address';
      INTERNET_STATUS_CONNECTION_CLOSED: s:= 'Successfully closed the connection to the server';
      INTERNET_STATUS_CTL_RESPONSE_RECEIVED: s:= 'Not implemented';
      INTERNET_STATUS_HANDLE_CLOSING: s:= 'This handle value has been terminated';
      INTERNET_STATUS_HANDLE_CREATED: s:= 'InternetConnect has created the new handle';
      INTERNET_STATUS_INTERMEDIATE_RESPONSE: s:=
        'Received an intermediate (100 level) status code message from the server';
      INTERNET_STATUS_NAME_RESOLVED: s:= 'Successfully found the IP address: ' + Format('%p',[pInformation]);
      INTERNET_STATUS_PREFETCH: s:= 'Not implemented';
      INTERNET_STATUS_RECEIVING_RESPONSE: s:= 'Waiting for the server to respond to a request ';
      INTERNET_STATUS_REDIRECT:
        begin
          s:= 'HTTP request is about to automatically redirect the request ' +
            Format('%p',[pInformation]);
          completed:= True;
        end;
      INTERNET_STATUS_REQUEST_COMPLETE:
        begin
          s:= 'An asynchronous operation has been completed';
          completed:= True;
          Sleep(5000);
        end;
      INTERNET_STATUS_REQUEST_SENT: s:= 'Successfully sent the information request to the server: ' +
        IntToStr(Integer(pInformation)) + ' Byte';
      INTERNET_STATUS_RESOLVING_NAME: s:= 'Looking up the IP address: ' + Format('%p',[pInformation]);
      INTERNET_STATUS_SENDING_REQUEST: s:= 'Sending the information request to the server.';
      INTERNET_STATUS_RESPONSE_RECEIVED:
        begin
          s:= 'Successfully received a response from the server: ' + IntToStr(Integer(pInformation)) + ' Byte';
          completed:= True;
        end;
      INTERNET_STATUS_STATE_CHANGE:
        begin
          s:= 'Moved between a secure (HTTPS) and a nonsecure (HTTP) site.';
          case DWORD(pInformation) of
            INTERNET_STATE_CONNECTED: s:= s + #13#10 + 'Connected state. Mutually exclusive with disconnected state.';
            INTERNET_STATE_DISCONNECTED: s:= s + #13#10 +
              'Disconnected state. No network connection could be established.';
            INTERNET_STATE_DISCONNECTED_BY_USER: s:= s + #13#10 + 'Disconnected by user request.';
            INTERNET_STATE_IDLE: s:= s + #13#10 + 'No network requests are being made by Windows Internet.';
            INTERNET_STATE_BUSY: s:= s + #13#10 + 'Network requests are being made by Windows Internet.';
          end;
        end;
    end;
    //FrmTesting.MmHTML.Lines.Add(s);
  end;

  function WaitAndStop: Boolean;
  begin // Цикл ожидания завершения запроса
    Result:= False;
    if FAsync then // применяется только в асинхронных вызовах
      while True do
      begin
        Sleep(1000);
        if FStop or completed then
        begin
          Result:= FStop;
          break;
        end;
      end;
  end;

var
  bytes, b, pos: Cardinal;
  hostname, script: string;
  Flags_connection, Flags_Request: Cardinal;
  DlgError, dwFlags: DWORD;
  Status: PFNInternetStatusCallback;
  iNetBuff : Internet_Buffers;
  lpReadBuff : Array [0..255] of AnsiChar;
const
  BufferSize = 1024*4;
begin
  Result:= EmptyAnsiStr;
  FStop:= False;
  hostname:= GetHostName(AURL); // имя хоста
  script:= GetScriptName(AURL, hostname); // скрипт
  // установка доп. параметров
  if not FPostData then // если передаем параметры через строку запроса, то
    if FParam <> EmptyStr then // дополняем скрипт
      if script[Length(script)] = '?' then
        script:= script + FParam
      else
        script:= script + '?' + FParam;
  try
    SetFlags(AURL, Flags_connection, Flags_Request); // Устанавливаем флаги (http или https)
    // Открываем сессию (инициализируем WinInet)
    case FAsync of
      False: dwFlags:= 0;
      True: dwFlags:= INTERNET_FLAG_ASYNC;
    end;
    FHttpSession:= InternetOpen(PChar(FClientName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, dwFlags);
    if FAsync then // Устанавливаем callback, если подключение асинхронное
    begin
      Status:= InternetSetStatusCallback(FHttpSession,INTERNET_STATUS_CALLBACK(@StatusCallback));
      if NativeInt(Status) = INTERNET_INVALID_STATUS_CALLBACK then
      begin
        Result:= AnsiString('Callback function is not valid');
        Exit;
      end;
    end;
    if Assigned(FHttpSession) then // Проверяем хэндл
    try // Открываем соединение
      FHttpConnect:= InternetConnect(FHttpSession, PChar(hostname), Flags_connection, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
      if Assigned(FHttpConnect) then // Проверяем хэндл
      try // Открываем запрос (передаем остаток URL (скрипт GetScriptName) в ф-ю HttpOpenRequest под параметром lpszObjectName)
        FHttpRequest:= HttpOpenRequest(FHttpConnect, PChar(FMethod), PChar(script), HTTP_VERSION, nil, nil, Flags_Request, 1);
        if Assigned(FHttpRequest) then // Проверяем хэндл
        try
          AddSecurityFlags(FHttpRequest); // Добавляем флаги
          completed:= False;
          SendRequest(FHttpRequest, FType_Access, FParam); // Отправляем запрос
          if WaitAndStop then // цикл ожидания вызова callback функции для асинхронных вызовов
          begin
            Result:= AnsiString('Остановлено');
            Exit;
          end;
          if GetStatus(FHttpRequest) = HTTP_STATUS_DENIED then
          begin // Если необходима авторизация
            if FLogin <> EmptyStr then
            begin
              InternetSetOption(FHttpRequest, INTERNET_OPTION_USERNAME, PChar(FLogin), SizeOf(FLogin));
              InternetSetOption(FHttpRequest, INTERNET_OPTION_PASSWORD, PChar(FPass), SizeOf(FPass));
            end
              else
              begin
                DlgError:= InternetErrorDlg(FHWND, FHttpRequest,
                   ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED,
                   FLAGS_ERROR_UI_FILTER_FOR_ERRORS
                or FLAGS_ERROR_UI_FLAGS_GENERATE_DATA
                   //or FLAGS_ERROR_UI_SERIALIZE_DIALOGS
                or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS,
                   PPointer(nil)^ );
                if DlgError = 0 then
                begin
                  Result:= AnsiString('Доступ запрещен! Ввод учетных данных отменен.'
                   + sLineBreak + SysErrorMessage(GetLastError));
                  Exit;
                end;
              end;
            SendRequest(FHttpRequest, FType_Access, FParam);
            if WaitAndStop then // цикл ожидания вызова callback функции для асинхронных вызовов
            begin
              Result:= AnsiString('Остановлено');
              Exit;
            end;
          end;
          case FAsync of
            False: // Обычное чтение
              if GetStatus(FHttpRequest) = HTTP_STATUS_OK then
              begin
                pos:= 1;
                b:= 1;
                while (b > 0) and (FStop = False) do
                begin // Если количество данных 0 - генерируем исключение
                  if not InternetQueryDataAvailable(FHttpRequest, bytes, 0, 0) then
                    Result:= AnsiString('Сервер не вернул данные! (функция InternetQueryDataAvailable)' + sLineBreak + SysErrorMessage(GetLastError));
                  SetLength(Result, Cardinal(Length(Result)) + bytes);
                  // Получаем данные с сервера
                  InternetReadFile(FHttpRequest, @Result[Pos], bytes, b);
                  Inc(Pos, b);
                end;

              end else
                Result:= AnsiString('ОШИБКА ' + IntToStr(GetStatus(FHttpRequest)) + sLineBreak + SysErrorMessage(GetLastError));
            True: // Асинхронное чтение
              begin
                BOK:= True;
                while BOK do
                begin
                  FillMemory(@iNetBuff, Sizeof(Internet_Buffers),0);
                  inetBuff.dwStructSize := Sizeof(Internet_Buffers);
                  inetBuff.lpvBuffer := @lpReadBuff;
                  inetBuff.dwBufferLength := Sizeof(lpReadBuff)-1;
                  if not InternetReadFileEX(FHttpRequest, @inetBuff, 0, 1) then
                    if WaitAndStop then // цикл ожидания вызова callback функции для асинхронных вызовов
                    begin
                      Result:= AnsiString('Остановлено');
                      Exit;
                    end;
                  if FStop then
                  begin
                    Result:= AnsiString('Остановлено');
                    Break;
                  end;
                  lpReadBuff[inetBuff.dwBufferlength]:= #0;
                  Result:= Result + lpReadBuff;
                  if inetBuff.dwBufferLength = 0 then BOK := False;
                end;
              end;
          end;
        finally
          InternetCloseHandle(FHttpRequest); // закрываем запрос
        end else
          Result:= AnsiString('Ошибка формирования запроса (функция HttpOpenRequest)' + sLineBreak + SysErrorMessage(GetLastError));
      finally
        InternetCloseHandle(FHttpConnect); // закрываем соединение
      end else
        Result:= AnsiString('Ошибка открытия сессии (функция InternetConnect)' + sLineBreak + SysErrorMessage(GetLastError));
    finally
      InternetCloseHandle(FHttpSession); // закрываем сессию
      //InternetSetOption(nil, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0);
      if FStop then
        Result:= AnsiString('Остановлено');
    end else
      Result:= AnsiString('Отсутствует подключение к сети (функция InternetOpen)' + sLineBreak + SysErrorMessage(GetLastError));
  except
    On E: Exception do
      Result:= AnsiString('Ошибка! ' + E.ClassName + ': ' + E.Message);
  end;
end;

end.


...
Рейтинг: 0 / 0
05.02.2020, 10:52
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922682
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
А не, все норм. Выскакивает авторизация. Не спрашивает логин с паролем, если используется предыдущий коннект, видимо который еще не закрылся.
Но проблема с загрузкой страницы со 2-го раза еще актуальна. Бывает сразу загружает, а бывает, что сначала пустую страницу, а потом нормально отрабатывает.
...
Рейтинг: 0 / 0
05.02.2020, 10:59
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922705
Zelius
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Zelius
Участник
aford,

может редирект не срабатывает?
...
Рейтинг: 0 / 0
05.02.2020, 11:33
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922717
Фотография Dmitry Arefiev
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Dmitry Arefiev
Участник
aford
А не, все норм. Выскакивает авторизация. Не спрашивает логин с паролем, если используется предыдущий коннект, видимо который еще не закрылся.

WinInet кэширует соединения и авторизацию в них
aford
Но проблема с загрузкой страницы со 2-го раза еще актуальна. Бывает сразу загружает, а бывает, что сначала пустую страницу, а потом нормально отрабатывает.

Http сниффер в помощь
...
Рейтинг: 0 / 0
05.02.2020, 11:46
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922720
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
Да, не срабатывает авторизация, 401 в сниффере. А 2-м запросом нормально.
Ну так я вроде и жду после отправки логина с паролем...

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
InternetSetOption(FHttpRequest, INTERNET_OPTION_USERNAME, PChar(FLogin), SizeOf(FLogin));
InternetSetOption(FHttpRequest, INTERNET_OPTION_PASSWORD, PChar(FPass), SizeOf(FPass));
SendRequest(FHttpRequest, FType_Access, FParam);
...
if WaitAndStop then // цикл ожидания вызова callback функции для асинхронных вызовов
begin
  Result:= AnsiString('Остановлено');
  Exit;
end;
...
Рейтинг: 0 / 0
05.02.2020, 11:50
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922723
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
А ожидание прерывается только при статусах INTERNET_STATUS_REDIRECT и INTERNET_STATUS_RESPONSE_RECEIVED
WaitAndStop выше в листинге, не буду дублировать
...
Рейтинг: 0 / 0
05.02.2020, 11:52
| Ответить | Цитировать | Написать  
Отменить HttpSendRequest в WinInet
    #39922768
aford
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
aford
Гость
Не дожидался утвердительного или отрицательного ответа сервера на аторизацию, поэтому пропускался этот шаг и выдавалась пустая страница. А дальше WinInet просто кэшировал авторизованное соединение и следующий запрос пропускал без проблем. Если запускать асинхронно, то завершить можно в любой момент. Вопрос решен, всем спасибо!

Приведу полный код, т.к. везде понемногу изменения:
 

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
283.
284.
285.
286.
287.
288.
289.
290.
291.
292.
293.
294.
295.
296.
297.
298.
299.
300.
301.
302.
303.
304.
305.
306.
307.
308.
309.
310.
311.
312.
313.
314.
315.
316.
317.
318.
319.
320.
321.
322.
323.
324.
325.
326.
327.
328.
329.
330.
331.
332.
333.
334.
335.
336.
337.
338.
339.
340.
341.
342.
343.
344.
345.
346.
347.
348.
349.
350.
351.
352.
353.
354.
355.
356.
357.
358.
359.
360.
361.
362.
363.
364.
365.
366.
367.
368.
369.
370.
371.
372.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
{
Если логин с паролем не указывать (в конструкторе или после создания), то , при
необходимости будет выскакивать окно с запросом
}

unit UnitWinInet;

interface

uses
  System.SysUtils, System.Types, WinInet, Winapi.Windows;

type

  TWinInet = class
    private
      FHWND: THandle; // Хэндл вызывающего приложения
      FClientName, // Имя клиента
      FParam, // параметры запроса (которые после ?)
      FMethod, // GET, POST и др.
      FType_Access, // mime type и проч, если установлен в '', то используется по умолчанию
      FLogin, // логин
      FPass: string; // пароль
      FPostData: boolean; //True - передача параметров запроса через post data, False - через строку запроса
      FStop: boolean; // вспомогательная переменная отв. за остановку скачки
      FHttpSession, FHttpConnect, FHttpRequest: HINTERNET;
      FAsync: Boolean;
      procedure SetMethod(AMethod: string);
    public
      property HWND: THandle read FHWND write FHWND;
      property ClientName: string read FClientName write FClientName;
      property Param: string read FParam write FParam;
      property Method: string read FMethod write SetMethod;
      property Type_Access: string read FType_Access write FType_Access;
      property Login: string read FLogin write FLogin;
      property Pass: string read FPass write FPass;
      property PostData: boolean read FPostData write FPostData;
      property Async: boolean read FAsync write FAsync;
      function GetHTTP(AURL: string): AnsiString;
      procedure CancelRequest;
      constructor Create(AHWND: THandle);
  end;

implementation

uses
  Vcl.Dialogs, System.Classes, UnitTesting;
var
  completed, BOK: boolean;

procedure TWinInet.CancelRequest;
begin
  FStop:= True;
  InternetCloseHandle(FHttpRequest);
  InternetCloseHandle(FHttpConnect);
  InternetCloseHandle(FHttpSession);
  InternetSetOption(nil, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0);
end;

constructor TWinInet.Create(AHWND: THandle);
begin
  FHWND:= AHWND;
  FClientName:= 'WinInet';
  FMethod:= 'GET';
  FType_Access:= 'Content-Type: application/x-www-form-urlenDELPHId' + #13#10 +
                   'Content-Length:' + IntToStr(length(FParam));
  FPostData:= False;
  FAsync:= True;
end;

procedure TWinInet.SetMethod(AMethod: string);
begin
  FMethod:= UpperCase(AMethod);
end;

function TWinInet.GetHTTP(AURL: string): AnsiString;

  function GetHostName(AUrl: string): string;
  var
    s: string;
  begin // Имя хоста
    if Pos('https://', AUrl) > 0 then
      s:= 'https://'
    else
      if Pos('http://', AUrl) > 0 then
        s:= 'http://'
      else
        s:= EmptyStr;
    if s <> EmptyStr then
      if Pos(s, AUrl) > 0 then
        Delete(AUrl, 1, Length(s));
    if Pos('/', AUrl) > 0 then
      SetLength(AUrl, Pos('/', AUrl) - 1);
    Result:= AUrl;
  end;

  function GetScriptName(AUrl, AHostname: string): string;
  begin // URL после имени хоста
    Result:= EmptyStr;
    Delete(AUrl, 1, Pos(AHostname, AUrl) + Length(AHostname));
    Result:= AUrl;
  end;

  procedure SetFlags(AUrl: string; out Flags_connection, Flags_Request: Cardinal);
  begin // Определяем https или http
    if Pos('https://', AUrl) > 0 then
    begin
      Flags_connection:= INTERNET_DEFAULT_HTTPS_PORT;
      Flags_Request:= INTERNET_FLAG_RELOAD
                   or INTERNET_FLAG_NO_CACHE_WRITE
                   or INTERNET_FLAG_SECURE
                   or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
                   or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID
                   //or INTERNET_FLAG_KEEP_CONNECTION
    end else
      begin
        Flags_connection:= INTERNET_DEFAULT_HTTP_PORT;
        Flags_Request:= INTERNET_FLAG_RELOAD
                     or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
                     or INTERNET_FLAG_NO_CACHE_WRITE
                     or INTERNET_FLAG_PRAGMA_NOCACHE
                     or INTERNET_FLAG_KEEP_CONNECTION;
      end;
  end;

  function GetResponseHeader(const hRequest: Pointer): string;
  var
    dwSize, Index: DWORD;
    szBuff: array [0..1024] of Char;
  begin // Возвращает заголовок ответа сервера в виде строк с CR/LF
    Index:= 0;
    dwSize:= SizeOf(szBuff);
    HttpQueryInfo(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, @szBuff, dwSize, Index);
    Result:= PChar(@szBuff);
  end;

  function GetStatus(const hRequest: Pointer): DWORD;
  var
    dwSize, dwStatus, Index: DWORD;
  begin // Возвращает заголовок ответа сервера в виде строк с CR/LF
    // Возвращает код статуса HTTP из заголовка ответа
    Index:= 0;
    dwSize:= SizeOf(dwStatus);
    HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @dwStatus, dwSize, Index);
    Result:= dwStatus;
  end;

  function AddSecurityFlags(httpReq: Pointer): Boolean;
  var
    dwSize, dwFlags: DWORD;
  begin
    Result:= False;
    dwSize:= SizeOf(dwFlags);     // Get the current security flags
    if (InternetQueryOption(httpReq, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, dwSize)) then
    begin // Add desired flags
       dwFlags:= dwFlags
         or SECURITY_FLAG_IGNORE_UNKNOWN_CA
         or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
         or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID
         or SECURITY_FLAG_IGNORE_REVOCATION;
       Result:= (InternetSetOption(httpReq,
              INTERNET_OPTION_SECURITY_FLAGS,
              @dwFlags,
              dwSize));
    end
  end;

  function SendRequest(httpRequest: Pointer; AType_Access, AParam: string): boolean;
  begin
    Result:= False;
    if (FStop = False) then
      case FPostData of
        False: Result:= HttpSendRequest(httpRequest, nil, 0, nil, 0);
        True: Result:= HttpSendRequest(httpRequest, PChar(AType_Access), Length(AType_Access), PChar(AParam), Length(AParam));
      end;
  end;

  procedure StatusCallback(hInet: HINTERNET; Context: DWORD_PTR; Status: DWORD; pInformation: Pointer;
    InfoLength: DWORD); stdcall;
  var
    s: string;
  begin
    case Status of
      INTERNET_STATUS_CLOSING_CONNECTION: s:= 'Closing the connection to the server';
      INTERNET_STATUS_CONNECTED_TO_SERVER: s:= 'Successfully connected to the socket address: ';
      INTERNET_STATUS_CONNECTING_TO_SERVER: s:= 'Connecting to the socket address';
      INTERNET_STATUS_CONNECTION_CLOSED: s:= 'Successfully closed the connection to the server';
      INTERNET_STATUS_CTL_RESPONSE_RECEIVED: s:= 'Not implemented';
      INTERNET_STATUS_HANDLE_CLOSING: s:= 'This handle value has been terminated';
      INTERNET_STATUS_HANDLE_CREATED: s:= 'InternetConnect has created the new handle';
      INTERNET_STATUS_INTERMEDIATE_RESPONSE: s:=
        'Received an intermediate (100 level) status code message from the server';
      INTERNET_STATUS_NAME_RESOLVED: s:= 'Successfully found the IP address: ' + Format('%p',[pInformation]);
      INTERNET_STATUS_PREFETCH: s:= 'Not implemented';
      INTERNET_STATUS_RECEIVING_RESPONSE: s:= 'Waiting for the server to respond to a request ';
      INTERNET_STATUS_REDIRECT:
        begin
          s:= 'HTTP request is about to automatically redirect the request ' +
            Format('%p',[pInformation]);
          completed:= True;
        end;
      INTERNET_STATUS_REQUEST_COMPLETE: s:= 'An asynchronous operation has been completed';
      INTERNET_STATUS_REQUEST_SENT: s:= 'Successfully sent the information request to the server: ' +
        IntToStr(Integer(pInformation)) + ' Byte';
      INTERNET_STATUS_RESOLVING_NAME: s:= 'Looking up the IP address: ' + Format('%p',[pInformation]);
      INTERNET_STATUS_SENDING_REQUEST: s:= 'Sending the information request to the server.';
      INTERNET_STATUS_RESPONSE_RECEIVED:
        begin
          s:= 'Successfully received a response from the server: ' + IntToStr(Integer(pInformation)) + ' Byte';
          completed:= True;
        end;
      INTERNET_STATUS_STATE_CHANGE:
        begin
          s:= 'Moved between a secure (HTTPS) and a nonsecure (HTTP) site.';
          case DWORD(pInformation) of
            INTERNET_STATE_CONNECTED: s:= s + #13#10 + 'Connected state. Mutually exclusive with disconnected state.';
            INTERNET_STATE_DISCONNECTED: s:= s + #13#10 +
              'Disconnected state. No network connection could be established.';
            INTERNET_STATE_DISCONNECTED_BY_USER: s:= s + #13#10 + 'Disconnected by user request.';
            INTERNET_STATE_IDLE: s:= s + #13#10 + 'No network requests are being made by Windows Internet.';
            INTERNET_STATE_BUSY: s:= s + #13#10 + 'Network requests are being made by Windows Internet.';
          end;
        end;
    end;
    //FrmTesting.MmHTML.Lines.Add(s);
  end;

  function WaitAndStop(AReq: Pointer; AAuth: Boolean; out ASt: DWORD): Boolean;
  begin // Цикл ожидания завершения запроса
    Result:= False;
    if FAsync then // применяется только в асинхронных вызовах
      while True do
      begin
        Sleep(1000);
        if FStop or completed then
        begin
          Result:= FStop;
          if not AAuth then // обычный запрос
          begin
            ASt:= GetStatus(FHttpRequest);
            break;
          end else // авторизация
          begin
            ASt:= GetStatus(FHttpRequest);
            if (ASt = HTTP_STATUS_OK) or (ASt = HTTP_STATUS_DENIED) then
              break;
          end;

        end;
      end;
  end;

var
  bytes, b, pos: Cardinal;
  hostname, script: string;
  Flags_connection, Flags_Request: Cardinal;
  DlgError, dwFlags, Auth: DWORD;
  Status: PFNInternetStatusCallback;
  iNetBuff : Internet_Buffers;
  lpReadBuff : Array [0..255] of AnsiChar;
const
  BufferSize = 1024*4;
begin
  Result:= EmptyAnsiStr;
  FStop:= False;
  hostname:= GetHostName(AURL); // имя хоста
  script:= GetScriptName(AURL, hostname); // скрипт
  // установка доп. параметров
  if not FPostData then // если передаем параметры через строку запроса, то
    if FParam <> EmptyStr then // дополняем скрипт
      if script[Length(script)] = '?' then
        script:= script + FParam
      else
        script:= script + '?' + FParam;
  try
    SetFlags(AURL, Flags_connection, Flags_Request); // Устанавливаем флаги (http или https)
    // Открываем сессию (инициализируем WinInet)
    case FAsync of
      False: dwFlags:= 0;
      True: dwFlags:= INTERNET_FLAG_ASYNC;
    end;
    FHttpSession:= InternetOpen(PChar(FClientName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, dwFlags);
    if FAsync then // Устанавливаем callback, если подключение асинхронное
    begin
      Status:= InternetSetStatusCallback(FHttpSession,INTERNET_STATUS_CALLBACK(@StatusCallback));
      if NativeInt(Status) = INTERNET_INVALID_STATUS_CALLBACK then
      begin
        Result:= AnsiString('Callback function is not valid');
        Exit;
      end;
    end;
    if Assigned(FHttpSession) then // Проверяем хэндл
    try // Открываем соединение
      FHttpConnect:= InternetConnect(FHttpSession, PChar(hostname), Flags_connection, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
      if Assigned(FHttpConnect) then // Проверяем хэндл
      try // Открываем запрос (передаем остаток URL (скрипт GetScriptName) в ф-ю HttpOpenRequest под параметром lpszObjectName)
        FHttpRequest:= HttpOpenRequest(FHttpConnect, PChar(FMethod), PChar(script), HTTP_VERSION, nil, nil, Flags_Request, 1);
        if Assigned(FHttpRequest) then // Проверяем хэндл
        try
          AddSecurityFlags(FHttpRequest); // Добавляем флаги
          completed:= False;
          SendRequest(FHttpRequest, FType_Access, FParam); // Отправляем запрос
          if WaitAndStop(FHttpRequest, False, Auth) then // цикл ожидания вызова callback функции для асинхронных вызовов
          begin
            Result:= AnsiString('Остановлено');
            Exit;
          end;
          if GetStatus(FHttpRequest) = HTTP_STATUS_DENIED then
          begin // Если необходима авторизация
            if FLogin <> EmptyStr then
            begin
              InternetSetOption(FHttpRequest, INTERNET_OPTION_USERNAME, PChar(FLogin), SizeOf(FLogin));
              InternetSetOption(FHttpRequest, INTERNET_OPTION_PASSWORD, PChar(FPass), SizeOf(FPass));
            end
              else
              begin
                DlgError:= InternetErrorDlg(FHWND, FHttpRequest,
                   ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED,
                   FLAGS_ERROR_UI_FILTER_FOR_ERRORS
                or FLAGS_ERROR_UI_FLAGS_GENERATE_DATA
                   //or FLAGS_ERROR_UI_SERIALIZE_DIALOGS
                or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS,
                   PPointer(nil)^ );
                if DlgError = 0 then
                begin
                  Result:= AnsiString('Доступ запрещен! Ввод учетных данных отменен.'
                   + sLineBreak + SysErrorMessage(GetLastError));
                  Exit;
                end;
              end;
            SendRequest(FHttpRequest, FType_Access, FParam);
            if WaitAndStop(FHttpRequest, True, Auth) then // цикл ожидания вызова callback функции для асинхронных вызовов
            begin
              Result:= AnsiString('Остановлено');
              Exit;
            end;
          end;
          case FAsync of
            False: // Обычное чтение
              if GetStatus(FHttpRequest) = HTTP_STATUS_OK then
              begin
                pos:= 1;
                b:= 1;
                while (b > 0) and (FStop = False) do
                begin // Если количество данных 0 - генерируем исключение
                  if not InternetQueryDataAvailable(FHttpRequest, bytes, 0, 0) then
                    Result:= AnsiString('Сервер не вернул данные! (функция InternetQueryDataAvailable)' + sLineBreak + SysErrorMessage(GetLastError));
                  SetLength(Result, Cardinal(Length(Result)) + bytes);
                  // Получаем данные с сервера
                  InternetReadFile(FHttpRequest, @Result[Pos], bytes, b);
                  Inc(Pos, b);
                end;

              end else
                Result:= AnsiString('ОШИБКА ' + IntToStr(GetStatus(FHttpRequest)) + sLineBreak + SysErrorMessage(GetLastError));
            True: // Асинхронное чтение
              if (Auth = HTTP_STATUS_OK) or (Auth = HTTP_STATUS_NOT_FOUND) then
              begin
                BOK:= True;
                while BOK do
                begin
                  FillMemory(@iNetBuff, Sizeof(Internet_Buffers),0);
                  inetBuff.dwStructSize := Sizeof(Internet_Buffers);
                  inetBuff.lpvBuffer := @lpReadBuff;
                  inetBuff.dwBufferLength := Sizeof(lpReadBuff)-1;
                  if not InternetReadFileEX(FHttpRequest, @inetBuff, 0, 1) then
                    if WaitAndStop(FHttpRequest, False, Auth) then // цикл ожидания вызова callback функции для асинхронных вызовов
                    begin
                      Result:= AnsiString('Остановлено');
                      Exit;
                    end;
                  if FStop then
                  begin
                    Result:= AnsiString('Остановлено');
                    Break;
                  end;
                  lpReadBuff[inetBuff.dwBufferlength]:= #0;
                  Result:= Result + lpReadBuff;
                  if inetBuff.dwBufferLength = 0 then BOK := False;
                end;
              end else
                if Auth = HTTP_STATUS_DENIED then
                  Result:= AnsiString('Доступ запрещен! Неверные учетные данные')
                else
                  Result:= AnsiString('ОШИБКА ' + IntToStr(GetStatus(FHttpRequest)) + sLineBreak + SysErrorMessage(GetLastError));

          end;
        finally
          InternetCloseHandle(FHttpRequest); // закрываем запрос
        end else
          Result:= AnsiString('Ошибка формирования запроса (функция HttpOpenRequest)' + sLineBreak + SysErrorMessage(GetLastError));
      finally
        InternetCloseHandle(FHttpConnect); // закрываем соединение
      end else
        Result:= AnsiString('Ошибка открытия сессии (функция InternetConnect)' + sLineBreak + SysErrorMessage(GetLastError));
    finally
      InternetCloseHandle(FHttpSession); // закрываем сессию
      //InternetSetOption(nil, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0);
      if FStop then
        Result:= AnsiString('Остановлено');
    end else
      Result:= AnsiString('Отсутствует подключение к сети (функция InternetOpen)' + sLineBreak + SysErrorMessage(GetLastError));
  except
    On E: Exception do
      Result:= AnsiString('Ошибка! ' + E.ClassName + ': ' + E.Message);
  end;
end;

end.


...
Рейтинг: 0 / 0
05.02.2020, 12:29
| Ответить | Цитировать | Написать  
17 сообщений из 17, страница 1 из 1
Форумы / Delphi [игнор отключен] [закрыт для гостей] / Отменить HttpSendRequest в WinInet
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение   Полит. конфиден.  
NoSQL.ru       Кролег: Проекты, Новости, Чат       РЕД ФОРУМ       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=58&msg=39922768&tid=2038633]:
 0ms
get settings:
 11ms
get forum list:
 17ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 147ms
get topic data:
 9ms
get forum data:
 2ms
get page messages:
 56ms
get tp. blocked users:
 1ms
others: 264ms
total:  513ms
созд. / загр.: 513ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]