Опытный
Профиль
Группа: Участник
Сообщений: 598
Регистрация: 17.2.2008
Репутация: нет
Всего: 6
|
Работает в асинхронном режиме, но, бывает, что загружает со 2-го раза страницу, где требуется авторизация. | Код |
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.
|
: Решение тутЭто сообщение отредактировал(а) neweraser - 5.2.2020, 12:32 --------------------
Кто ищет, тот всегда найдет. |
Отменить HttpSendRequest в WinInet 
Загрузка ...
Но может что не так делаю.
