Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
||
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[44.222.104.49] |
|
Сообщ.
#1
,
|
|
|
//////////////////////////////////////////////////////////////////////////////// // // **************************************************************************** // * Project : DownloadViaProxy // * Purpose : Демо скачивания файла с учетом бейсик авторизации и прокси // * Author : Александр (Rouse_) Багель // * Copyright : © Fangorn Wizards Lab 1998 - 2007. // * Version : 1.03 // * Home Page : http://rouse.drkb.ru // **************************************************************************** // program DownloadViaProxy; {$APPTYPE CONSOLE} uses Windows, SysUtils, Classes, WinInet; type TDownloadParams = record FileURL, // Запрос для файла Proxy, // список прокси ProxyBypass, // дополниотельный список прокси AuthUserName, // логин для Authorization: Basic AuthPassword: String; // пароль для Authorization: Basic DownloadFrom, // смещение от начала данных NeedDataSize: DWORD; // необходимый размер end; function DownloadFileEx( Params: TDownloadParams; OutputData: TStream): Boolean; function DelHttp(URL: String): String; var HttpPos: Integer; begin HttpPos := Pos('http://', URL); if HttpPos > 0 then Delete(Url, HttpPos, 7); Result := Copy(Url, 1, Pos('/', Url) - 1); if Result = '' then Result := URL; end; const Accept = 'Accept: */*' + sLineBreak; ProxyConnection = 'Proxy-Connection: Keep-Alive' + sLineBreak; LNG = 'Accept-Language: ru' + sLineBreak; AGENT = 'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; ' + 'Windows NT 5.1; SV1; .NET CLR 2.0.50727)' + sLineBreak; var FSession, FConnect, FRequest: HINTERNET; FHost, FScript, SRequest, ARequest: String; Buff, IntermediateBuffer: array of Byte; BytesRead, Res, Len, FilePosition, OpenTypeFlags, ContentLength: Cardinal; begin Result := False; ARequest := Params.FileURL; // Небольшой парсинг // вытаскиваем имя хоста и параметры обращения к скрипту FHost := DelHttp(ARequest); FScript := ARequest; Delete(FScript, 1, Pos(FHost, FScript) + Length(FHost)); // Инициализируем WinInet if Params.Proxy = '' then OpenTypeFlags := INTERNET_OPEN_TYPE_PRECONFIG else OpenTypeFlags := INTERNET_OPEN_TYPE_PROXY; FSession := InternetOpen('', OpenTypeFlags, PChar(Params.Proxy), PChar(Params.ProxyBypass), 0); if not Assigned(FSession) then Exit; try // Попытка соединения с сервером FConnect := InternetConnect(FSession, PChar(FHost), INTERNET_DEFAULT_HTTP_PORT, PChar(Params.AuthUserName), PChar(Params.AuthPassword), INTERNET_SERVICE_HTTP, 0, 0); if not Assigned(FConnect) then Exit; try // Подготавливаем запрос FRequest := HttpOpenRequest(FConnect, 'GET', PChar(FScript), nil, '', nil, 0, 0); // добавляем необходимые заголовки к запросу HttpAddRequestHeaders(FRequest, Accept, Length(Accept), HTTP_ADDREQ_FLAG_ADD); HttpAddRequestHeaders(FRequest, ProxyConnection, Length(ProxyConnection), HTTP_ADDREQ_FLAG_ADD); HttpAddRequestHeaders(FRequest, LNG, Length(LNG), HTTP_ADDREQ_FLAG_ADD); HttpAddRequestHeaders(FRequest, AGENT, Length(AGENT), HTTP_ADDREQ_FLAG_ADD); // Проверяем запрос: Len := 0; Res := 0; SRequest := ' '; HttpQueryInfo(FRequest, HTTP_QUERY_RAW_HEADERS_CRLF or HTTP_QUERY_FLAG_REQUEST_HEADERS, @SRequest[1], Len, Res); if Len > 0 then begin SetLength(SRequest, Len); HttpQueryInfo(FRequest, HTTP_QUERY_RAW_HEADERS_CRLF or HTTP_QUERY_FLAG_REQUEST_HEADERS, @SRequest[1], Len, Res); end; if not Assigned(FConnect) then Exit; try // Отправляем запрос if not (HttpSendRequest(FRequest, nil, 0, nil, 0)) then Exit; // Узнаем размер файла ContentLength := InternetSetFilePointer( FRequest, 0, nil, FILE_END, 0); if ContentLength = DWORD(-1) then ContentLength := 0; // выставляем позцию, откуда нужно начинать скачку FilePosition := InternetSetFilePointer( FRequest, Params.DownloadFrom, nil, FILE_BEGIN, 0); if FilePosition = DWORD(-1) then FilePosition := 0; // Выставляем размер приемного буффера if Params.NeedDataSize = 0 then Params.NeedDataSize := ContentLength; if Integer(FilePosition) + Params.NeedDataSize > Integer(ContentLength) then Params.NeedDataSize := ContentLength - FilePosition; // если не смогли определить размер данных - читаем все что прочтется if Params.NeedDataSize <= 0 then begin SetLength(IntermediateBuffer, 8192); ContentLength := 0; Params.NeedDataSize := 0; BytesRead := 0; while InternetReadFile(FRequest, @IntermediateBuffer[0], 100, BytesRead) do if BytesRead > 0 then begin SetLength(Buff, ContentLength + BytesRead); Move(IntermediateBuffer[0], Buff[ContentLength], BytesRead); Inc(ContentLength, BytesRead); end else begin Params.NeedDataSize := ContentLength; Break; end; end else begin // в противном случае, принимаем данные как обычно SetLength(Buff, Params.NeedDataSize); if not InternetReadFile(FRequest, @Buff[0], Params.NeedDataSize, BytesRead) then Exit; end; OutputData.Write(Buff[0], Params.NeedDataSize); Result := True; finally InternetCloseHandle(FRequest); end; finally InternetCloseHandle(FConnect); end; finally InternetCloseHandle(FSession); end; end; var Params: TDownloadParams; Data: TMemoryStream; begin try ZeroMemory(@Params, SizeOf(TDownloadParams)); Params.FileURL := 'http://google.com/index.html'; Data := TMemoryStream.Create; try if DownloadFileEx(Params, Data) then Data.SaveToFile('c:\test.htm'); finally Data.Free; end; except on E:Exception do Writeln(E.Classname, ': ', E.Message); end; end. Еще пример использования function GetMultiproxyProxyList(ResultList: TStringList): Boolean; var Params: TDownloadParams; Data: TStringStream; AResult: String; begin Result := False; ZeroMemory(@Params, SizeOf(TDownloadParams)); Params.FileURL := 'http://multiproxy.org/txt_all/proxy.txt'; Data := TStringStream.Create(''); try if DownloadFileEx(Params, Data) then begin SetLength(AResult, Data.Size); Data.Read(AResult, Data.Size); ResultList.Text := AResult; Result := True; end; finally Data.Free; end; end; Еще один пример использования, но вот этот сервер не дает размер файла: function GetProxyListOrgProxyList(ResultList: TStringList): Boolean; var Params: TDownloadParams; Data: TStringStream; AResult: String; begin Result := False; ZeroMemory(@Params, SizeOf(TDownloadParams)); Params.FileURL := 'http://proxy-list.org/downloadproxylist.php?sp=-1&pp=any&pt=any&pc=any&ps=any'; // Params.DownloadFrom := 4; // <- попытка дозакачки... Data := TStringStream.Create(''); try if DownloadFileEx(Params, Data) then begin if Data.Size = 0 then begin ResultList.Add('Сервер не поддерживает дозакачку.'); Exit; end; SetLength(AResult, Data.Size); Data.Read(AResult, Data.Size); ResultList.Text := AResult; Result := True; end; finally Data.Free; end; end; |
Сообщ.
#2
,
|
|
|
Вот полноценный набор классов для работы с HTTP без браузера.
Способен работать через Proxy и не боится плохой связи. Даю как есть, не сочтите за рекламу Код реально работает, передаёт и принимает любые файлы и позволяет надстраивать над CustomChannel классы для произвольных протоколов. Поскольку ничего кроме HTTP было не нужно, то иерархия такая: TCustomChannel -> THttpChannel. Для компиляции под Delphi 5 и старше, также для правильной работы в системе должен быть установлен IE5 или старше - иначе WinInet может работать неправильно. Исходное название - Channels.pas {============================================================================== Copyright (C) 2006-2007 Denisov Alexey Vladimirovich for Tewek Ltd mailto:alexey-denisov@mail.ru or mailto:alexey-denisov@tewek.ru Эта программа является свободным программным обеспечением. Вы можете распространять и/или модифицировать её согласно условиям Стандартной Общественной Лицензии GNU, опубликованной Фондом Свободного Программного Обеспечения, версии 3 или, по Вашему желанию, любой более поздней версии. Эта программа распространяется в надежде, что она будет полезной, но БЕЗ ВСЯКИХ ГАРАНТИЙ, в том числе подразумеваемых гарантий ТОВАРНОГО СОСТОЯНИЯ ПРИ ПРОДАЖЕ и ГОДНОСТИ ДЛЯ ОПРЕДЕЛЁННОГО ПРИМЕНЕНИЯ. Смотрите Стандартную Общественную Лицензию GNU для получения дополнительной информации. Вы должны были получить копию Стандартной Общественной Лицензии GNU вместе с программой. В случае её отсутствия, посмотрите <http://www.gnu.org/licenses/>. ==============================================================================} // Каналы. Модуль служит для организации связи. // Содержит базовый класс канала. // Обеспечивает также чтение/запись через HTTP, в основном или // дополнительном потоке, по выбору. {$I defines.pas} // Если раскомментировать, то все запросы к WinInet будут записываться // в лог ChangeFileExt(Application.ExeName, '.channel.log'); {$IFOPT O-} //{$DEFINE WRITELOG} {$ENDIF} unit Channels; interface uses Windows, Forms, SysUtils, Classes, ExtCtrls, WinInet; type TUserAgentRec = record Ident: String; Agent: String; end; const // из MFC HTTP_VERB_POST = 0; HTTP_VERB_GET = 1; HTTP_VERB_HEAD = 2; HTTP_VERB_PUT = 3; HTTP_VERB_LINK = 4; HTTP_VERB_DELETE = 5; HTTP_VERB_UNLINK = 6; USER_AGENT_COUNT = 38; USER_AGENT_DEFAULT = 0; USER_AGENT_IE5 = USER_AGENT_DEFAULT; UserAgents: array[0..USER_AGENT_COUNT-1] of TUserAgentRec = (( Ident: 'Internet Explorer 5.0'; Agent: 'Mozilla/4.0 (compatible; MSIE 5.01; Windows NT 5.0)'), ( Ident: 'Amaya 9'; Agent: 'amaya/9.53 libwww/5.4.0'), ( Ident: 'Avant Browser (old)'; Agent: 'Avant Browser (http://www.avantbrowser.com)'), ( Ident: 'Avant Browser (new)'; Agent: 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Avant Browser [avantbrowser.com]; iOpus-I-M; QXW03416; .NET CLR 1.1.4322)'), ( Ident: 'Camino'; Agent: 'Mozilla/5.0 (Macintosh; U; PPC Max OS X Mach-O; en-US; rv:1.8.0.7) Gecko/200609211 Camino/1.0.3'), ( Ident: 'ELinks'; Agent: 'ELinks (0.4pre5; Linux 2.4.27 i686; 80x25)'), ( Ident: 'Epiphany'; Agent: 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.0.7) Gecko/20060928 (Debian|Debian-1.8.0.7-1) Epiphany/2.14'), ( Ident: 'Firefox (Linux)'; Agent: 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.2) Gecko/20070220 Firefox/2.0.0.2'), ( Ident: 'Firefox (MacOS)'; Agent: 'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-US; rv:1.8.0.7) Gecko/20060909 Firefox/1.5.0.7'), ( Ident: 'Firefox (Windows)'; Agent: 'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.1.6) Gecko/20070725 Firefox/2.0.0.6'), ( Ident: 'Flock'; Agent: 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.0.7) Gecko/20061031 Firefox/1.5.0.7 Flock/0.7.7'), ( Ident: 'Googlebot'; Agent: 'Googlebot/2.1 (+http://www.google.com/bot.html)'), ( Ident: 'iCab'; Agent: 'Mozilla/5.0 (compatible; iCab 3.0.3; Macintosh; U; PPC Mac OS X)'), ( Ident: 'Internet Explorer 1.0'; Agent: 'Microsoft Internet Explorer/4.0b1 (Windows 95)'), ( Ident: 'Internet Explorer 1.5'; Agent: 'Mozilla/1.22 (compatible; MSIE 1.5; Windows NT)'), ( Ident: 'Internet Explorer 2.0'; Agent: 'Mozilla/1.22 (compatible; MSIE 2.0; Windows 95)'), ( Ident: 'Internet Explorer 3.0'; Agent: 'Mozilla/2.0 (compatible; MSIE 3.01; Windows 98)'), ( Ident: 'Internet Explorer 6.0'; Agent: 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)'), ( Ident: 'Internet Explorer 7.0'; Agent: 'Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)'), ( Ident: 'K-Meleon'; Agent: 'Mozilla/5.0 (Windows; U; WinNT4.0; en-US; rv:1.8.0.5) Gecko/20060706 K-Meleon/1.0'), ( Ident: 'Konqueror'; Agent: 'Mozilla/5.0 (compatible; Konqueror/3.5; Linux) KHTML/3.5.5 (like Gecko) (Debian|Debian)'), ( Ident: 'Links'; Agent: 'Links (2.1pre17; Linux 2.6.11-gentoo-r8 i686; 80x24)'), ( Ident: 'Lynx'; Agent: 'Lynx/2.8.4rel.1 libwww-FM/2.14'), ( Ident: 'Minimo'; Agent: 'Mozilla/5.0 (Windows; U; Windows CE 4.21; rv:1.8b4) Gecko/20050720 Minimo/0.007'), ( Ident: 'Mozilla'; Agent: 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7.8) Gecko/20050511'), ( Ident: 'NetPositive'; Agent: 'Mozilla/3.0 (compatible; NetPositive/2.2)'), ( Ident: 'Netscape'; Agent: 'Mozilla/5.0 (Windows; U; Windows NT 5.0; en-US; rv:0.9.2) Gecko/20020508 Netscape6/6.1'), ( Ident: 'Netscape Navigator'; Agent: 'Mozilla/4.8 [en] (Windows NT 5.0; U)'), ( Ident: 'Off By One'; Agent: 'Mozilla/4.7 (compatible; OffByOne; Windows 2000)'), ( Ident: 'OmniWeb'; Agent: 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-US) AppleWebKit/125.4 (KHTML, like Gecko, Safari) OmniWeb/v563.51'), ( Ident: 'Openwave'; Agent: 'OPWV-SDK/62 UP.Browser/6.2.2.1.208 (GUI) MMP/2.0'), ( Ident: 'Opera'; Agent: 'Opera/9.10 (Windows NT 5.1; U; en)'), ( Ident: 'PlayStation 3'; Agent: 'Mozilla/5.0 (PLAYSTATION 3; 1.00)'), ( Ident: 'Safari'; Agent: 'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3'), ( Ident: 'SeaMonkey'; Agent: 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.2pre) Gecko/20070111 SeaMonkey/1.1'), ( Ident: 'Shiira'; Agent: 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; de-de) AppleWebKit/418 (KHTML, like Gecko) Shiira/1.2.2 Safari/125'), ( Ident: 'w3m'; Agent: 'w3m/0.5.1'), ( Ident: 'WebExplorer'; Agent: 'IBM-WebExplorer-DLL/v1.1h')); function SetStr(Condition: Boolean; const TrueStr: String; const FalseStr: String = ''): String; type TCustomChannel = class; TChannelClass = class of TCustomChannel; TChannelEvent = TNotifyEvent; TOnChannelBeforeCloseEvent = procedure(Sender: TObject; var CanClose: Boolean) of object; TOnChannelBeforeDisconnectEvent = procedure(Sender: TObject; var CanDisconnect: Boolean) of object; TOnChannelErrorEvent = procedure(Sender: TObject; const ErrorCode: Cardinal) of object; TCustomChannel = class private FHInet: HINTERNET; FHConnect: HINTERNET; FDestinationData: String; FReceivedData: String; FFlags: Cardinal; FObjectName: String; FServerPort: Word; FProxy: String; FProxyBypass: String; FUserPassword: String; FServerName: String; FServiceType: Word; FUserAgent: String; FUserName: String; FOnBeforeOpen: TNotifyEvent; FOnOpened: TNotifyEvent; FOnBeforeConnect: TNotifyEvent; FOnConnected: TNotifyEvent; FOnBeforeClose: TOnChannelBeforeCloseEvent; FOnClosed: TNotifyEvent; FLastError: Cardinal; FOnBeforeDisconnect: TOnChannelBeforeDisconnectEvent; FOnDisconnected: TNotifyEvent; FOnError: TOnChannelErrorEvent; FTimeout: Word; FProxyUser: String; FProxyPassword: String; FUseProxy: Boolean; FProxyNeedAuthorization: Boolean; procedure BeforeOpen; procedure AfterOpen; function CanClose: Boolean; virtual; procedure AfterClose; procedure BeforeConnect; procedure AfterConnect; function CanDisconnect: Boolean; virtual; procedure AfterDisconnect; protected function InternetCloseHandle(var Handle: Pointer): Boolean; function SetError(Success: Boolean): Boolean; function GetDestinationData: String; virtual; procedure SetDestinationData(const Value: String); virtual; function DoOpen: Boolean; virtual; function DoClose: Boolean; virtual; function DoConnect: Boolean; virtual; function DoDisconnect: Boolean; virtual; property Flags: Cardinal read FFlags write FFlags; public destructor Destroy; override; { подключение } function Opened: Boolean; function Open: Boolean; virtual; function Closed: Boolean; function Close: Boolean; virtual; function Connected: Boolean; // если входные параметры не указаны, // берёт из свойств function Connect(const ServerName: String = ''; const UserName: String = ''; const UserPassword: String = ''): Boolean; virtual; function Disconnected: Boolean; function Disconnect: Boolean; virtual; { данные } { чтение и запись } function GetDataSize(out DataSize: Cardinal): Boolean; function Read(DataSize: Cardinal; var S: String): Boolean; overload; virtual; function Read(DataSize: Cardinal = 0): Boolean; overload; virtual; function Write(S: String = ''): Boolean; virtual; { ошибки } function GetLastError: Cardinal; { общие свойства протоколов } property DestinationData: String read GetDestinationData write SetDestinationData; property ReceivedData: String read FReceivedData; property HInet: HINTERNET read FHInet; property HConnect: HINTERNET read FHConnect; published { общие свойства протоколов } property ObjectName: String read FObjectName write FObjectName; property ServerPort: Word read FServerPort write FServerPort; property Timeout: Word read FTimeout write FTimeout; property Proxy: String read FProxy write FProxy; property ProxyBypass: String read FProxyBypass write FProxyBypass; property UserName: String read FUserName write FUserName; property UserPassword: String read FUserPassword write FUserPassword; property ProxyNeedAuthorization: Boolean read FProxyNeedAuthorization write FProxyNeedAuthorization; property ProxyUser: String read FProxyUser write FProxyUser; property ProxyPassword: String read FProxyPassword write FProxyPassword; property UseProxy: Boolean read FUseProxy write FUseProxy; property ServerName: String read FServerName write FServerName; property ServiceType: Word read FServiceType; property UserAgent: String read FUserAgent write FUserAgent; { события } property OnBeforeOpen: TNotifyEvent read FOnBeforeOpen write FOnBeforeOpen; property OnOpened: TNotifyEvent read FOnOpened write FOnOpened; property OnBeforeClose: TOnChannelBeforeCloseEvent read FOnBeforeClose write FOnBeforeClose; property OnClosed: TNotifyEvent read FOnClosed write FOnClosed; property OnBeforeConnect: TNotifyEvent read FOnBeforeConnect write FOnBeforeConnect; property OnConnected: TNotifyEvent read FOnConnected write FOnConnected; property OnBeforeDisconnect: TOnChannelBeforeDisconnectEvent read FOnBeforeDisconnect write FOnBeforeDisconnect; property OnDisconnected: TNotifyEvent read FOnDisconnected write FOnDisconnected; property OnError: TOnChannelErrorEvent read FOnError write FOnError; { переопределяемые при необходимости } public procedure Assign(Channel: TCustomChannel); virtual; { обязательно переопределяемые } public constructor Create; virtual; function DoGetDataSize(out DataSize: Cardinal): Boolean; virtual; abstract; function DoRead(DataSize: Cardinal; var S: String): Boolean; virtual; abstract; function DoWrite(const S: String): Boolean; virtual; abstract; end; THttpChannel = class(TCustomChannel) private FHRequest: HINTERNET; FDataList: TStringList; FBoundary: String; protected property HRequest: HINTERNET read FHRequest; property DataList: TStringList read FDataList; property Boundary: String read FBoundary; function CreateBoundary: String; function OpenRequest(Verb: Integer; Flags: Cardinal; const ObjectName: String = ''): Boolean; virtual; function SendRequest(const Header, Data: String): Boolean; virtual; function CloseRequest: Boolean; virtual; procedure SetDestinationData(const Value: String); override; function GetDestinationData: String; override; public destructor Destroy; override; // Добавляет поле в буфер для отправляемых данных function AddDestinationData(const FieldName, FieldValue: String): String; // Аналогично AddDestinationData, но если нет файла, // то вернёт пустую строку function AddDestinationFile(const FieldName, FileName: String): String; { переопределяемые при необходимости } public procedure Assign(Channel: TCustomChannel); override; { обязательно переопределяемые } public constructor Create; override; function DoGetDataSize(out DataSize: Cardinal): Boolean; override; function DoRead(DataSize: Cardinal; var S: String): Boolean; override; function DoWrite(const S: String): Boolean; override; end; implementation function SetStr(Condition: Boolean; const TrueStr: String; const FalseStr: String = ''): String; begin if Condition then Result := TrueStr else Result := FalseStr; end; function GetTickCount: Cardinal; external 'kernel32.dll' name 'GetTickCount'; function IsTimeout(StartCount, TickCount: Cardinal; TimeoutSec: Word): Boolean; var lDelta: Cardinal; begin lDelta := TickCount - StartCount; if StartCount > TickCount then lDelta := Cardinal(-1) + Succ(lDelta); Result := (lDelta > TimeoutSec*1000); end; {$IFDEF WRITELOG} procedure WriteLog(const S: String); var lFileName: String; f: TextFile; begin lFileName := ChangeFileExt(Application.ExeName, '.channel.log'); AssignFile(f, lFileName); if FileExists(lFileName) then Append(f) else Rewrite(f); WriteLn(f, S); CloseFile(f); end; function BS(Value: Boolean): String; begin if Value then Result := 'True' else Result := 'False'; end; function InternetQueryDataAvailable(hFile: HINTERNET; var lpdwNumberOfBytesAvailable: DWORD; dwFlags, dwContext: DWORD): BOOL; var S: String; begin Result := WinInet.InternetQueryDataAvailable(hFile, lpdwNumberOfBytesAvailable, dwFlags, dwContext); S := 'InternetQueryDataAvailable hFile=%u lpdwNumberOfBytesAvailable=%u dwFlags=%u dwContext=%u Result=%s GetLastError=%d'; WriteLog(Format(S, [DWORD(hFile), lpdwNumberOfBytesAvailable, dwFlags, dwContext, BS(Result), GetLastError])); end; function InternetOpen(lpszAgent: PChar; dwAccessType: DWORD; lpszProxy, lpszProxyBypass: PChar; dwFlags: DWORD): HINTERNET; var S: String; begin WriteLog(''); WriteLog(''); Result := WinInet.InternetOpen(lpszAgent, dwAccessType, lpszProxy, lpszProxyBypass, dwFlags); S := 'InternetOpen lpszAgent=%s dwAccessType=%u lpszProxy=%s lpszProxyBypass=%s dwFlags=%u Result=%u GetLastError=%d'; WriteLog(Format(S, [lpszAgent, dwAccessType, lpszProxy, lpszProxyBypass, dwFlags, DWORD(Result), GetLastError])); end; function InternetSetOption(hInet: HINTERNET; dwOption: DWORD; lpBuffer: Pointer; dwBufferLength: DWORD): BOOL; var S: String; begin Result := WinInet.InternetSetOption(hInet, dwOption, lpBuffer, dwBufferLength); S := 'InternetSetOption hInet=%u dwOption=%u dwBufferLength=%u Result=%s GetLastError=%d'; WriteLog(Format(S, [DWORD(hInet), dwOption, dwBufferLength, BS(Result), GetLastError])); end; function InternetConnect(hInet: HINTERNET; lpszServerName: PChar; nServerPort: INTERNET_PORT; lpszUsername: PChar; lpszPassword: PChar; dwService: DWORD; dwFlags: DWORD; dwContext: DWORD): HINTERNET; var S: String; begin Result := WinInet.InternetConnect(hInet, lpszServerName, nServerPort, lpszUsername, lpszPassword, dwService, dwFlags, dwContext); S := 'InternetConnect hInet=%u lpszServerName=%s nServerPort=%u lpszUsername=%s lpszPassword=%s dwService=%u dwFlags=%u dwContext=%u Result=%u GetLastError=%d'; WriteLog(Format(S, [DWORD(hInet), lpszServerName, nServerPort, lpszUsername, lpszPassword, dwService, dwFlags, dwContext, DWORD(Result), GetLastError])); end; function InternetReadFile(hFile: HINTERNET; lpBuffer: Pointer; dwNumberOfBytesToRead: DWORD; var lpdwNumberOfBytesRead: DWORD): BOOL; var S: String; begin Result := WinInet.InternetReadFile(hFile, lpBuffer, dwNumberOfBytesToRead, lpdwNumberOfBytesRead); S := 'InternetReadFile hFile=%u dwNumberOfBytesToRead=%u lpdwNumberOfBytesRead=%u Result=%s GetLastError=%d'; WriteLog(Format(S, [DWORD(hFile), dwNumberOfBytesToRead, lpdwNumberOfBytesRead, BS(Result), GetLastError])); end; function InternetWriteFile(hFile: HINTERNET; lpBuffer: Pointer; dwNumberOfBytesToWrite: DWORD; var lpdwNumberOfBytesWritten: DWORD): BOOL; var S: String; begin Result := WinInet.InternetWriteFile(hFile, lpBuffer, dwNumberOfBytesToWrite, lpdwNumberOfBytesWritten); S := 'InternetWriteFile hFile=%u dwNumberOfBytesToWrite=%u lpdwNumberOfBytesWritten=%u Result=%s GetLastError=%d'; WriteLog(Format(S, [DWORD(hFile), dwNumberOfBytesToWrite, lpdwNumberOfBytesWritten, BS(Result), GetLastError])); end; function HttpOpenRequest(hConnect: HINTERNET; lpszVerb: PChar; lpszObjectName: PChar; lpszVersion: PChar; lpszReferrer: PChar; lplpszAcceptTypes: PLPSTR; dwFlags: DWORD; dwContext: DWORD): HINTERNET; var S: String; begin Result := WinInet.HttpOpenRequest(hConnect, lpszVerb, lpszObjectName, lpszVersion, lpszReferrer, lplpszAcceptTypes, dwFlags, dwContext); S := 'HttpOpenRequest hConnect=%u lpszVerb=%s lpszObjectName=%s lpszVersion=%s dwFlags=%u dwContext=%u Result=%u GetLastError=%d'; WriteLog(Format(S, [DWORD(hConnect), lpszVerb, lpszObjectName, lpszVersion, dwFlags, dwContext, DWORD(Result), GetLastError])); end; function HttpSendRequest(hRequest: HINTERNET; lpszHeaders: PChar; dwHeadersLength: DWORD; lpOptional: Pointer; dwOptionalLength: DWORD): BOOL; var S: String; begin Result := WinInet.HttpSendRequest(hRequest, lpszHeaders, dwHeadersLength, lpOptional, dwOptionalLength); S := 'HttpSendRequest(hRequest=%u lpszHeaders=%s dwHeadersLength=%u Result=%s GetLastError=%d'; WriteLog(Format(S, [DWORD(hRequest), lpszHeaders, dwHeadersLength, BS(Result), GetLastError])); end; function InternetCloseHandle(hInet: HINTERNET): BOOL; var S: String; begin Result := WinInet.InternetCloseHandle(hInet); S := 'InternetCloseHandle hInet=%u Result=%s GetLastError=%d'; WriteLog(Format(S, [DWORD(hInet), BS(Result), GetLastError])); end; {$ENDIF} { TCustomChannel } constructor TCustomChannel.Create; begin inherited; Timeout := 20; Flags := INTERNET_FLAG_PRAGMA_NOCACHE + INTERNET_FLAG_RELOAD; UserAgent := UserAgents[USER_AGENT_DEFAULT].Agent; UseProxy := False; UserName := ''; UserPassword := ''; ProxyUser := ''; ProxyPassword := ''; end; destructor TCustomChannel.Destroy; begin Close; inherited; end; procedure TCustomChannel.Assign(Channel: TCustomChannel); begin Self.FHInet := Channel.FHInet; Self.FHConnect := Channel.FHConnect; Self.FDestinationData := Channel.FDestinationData; Self.FReceivedData := Channel.FReceivedData; Self.FFlags := Channel.FFlags; Self.FObjectName := Channel.FObjectName; Self.FServerPort := Channel.FServerPort; Self.FProxy := Channel.FProxy; Self.FProxyBypass := Channel.FProxyBypass; Self.FUserPassword := Channel.FUserPassword; Self.FUserName := Channel.FUserName; Self.FProxyUser := Channel.FProxyUser; Self.FProxyPassword := Channel.FProxyPassword; Self.FUseProxy := Channel.FUseProxy; Self.FProxyNeedAuthorization := Channel.FProxyNeedAuthorization; Self.FUserAgent := Channel.FUserAgent; Self.FServerName := Channel.FServerName; Self.FServiceType := Channel.FServiceType; Self.FOnBeforeOpen := Channel.FOnBeforeOpen; Self.FOnOpened := Channel.FOnOpened; Self.FOnBeforeConnect := Channel.FOnBeforeConnect; Self.FOnConnected := Channel.FOnConnected; Self.FOnBeforeClose := Channel.FOnBeforeClose; Self.FOnClosed := Channel.FOnClosed; Self.FLastError := Channel.FLastError; Self.FOnBeforeDisconnect := Channel.FOnBeforeDisconnect; Self.FOnDisconnected := Channel.FOnDisconnected; Self.FOnError := Channel.FOnError; end; // ===== TCustomChannel - functions ==================================== function TCustomChannel.GetLastError: Cardinal; begin Result := FLastError; FLastError := 0; end; function TCustomChannel.InternetCloseHandle(var Handle: Pointer): Boolean; begin {$IFDEF WRITELOG} Result := Channels.InternetCloseHandle(Handle); {$ELSE} Result := WinInet.InternetCloseHandle(Handle); {$ENDIF} if Result then Handle := nil; end; function TCustomChannel.SetError(Success: Boolean): Boolean; begin if Success then FLastError := 0 else begin FLastError := Windows.GetLastError; if Assigned(FOnError) then FOnError(Self, FLastError); end; Result := Success; end; function TCustomChannel.GetDataSize(out DataSize: Cardinal): Boolean; begin Result := SetError(DoGetDataSize(DataSize)); end; function TCustomChannel.GetDestinationData: String; begin Result := FDestinationData; end; procedure TCustomChannel.SetDestinationData(const Value: String); begin FDestinationData := Value; end; function TCustomChannel.Read(DataSize: Cardinal; var S: String): Boolean; begin if DataSize = 0 then DataSize := Cardinal(-1); Result := SetError(DoRead(DataSize, S)); FReceivedData := SetStr(Result, S); end; function TCustomChannel.Read(DataSize: Cardinal = 0): Boolean; begin Result := Read(DataSize, FReceivedData); end; function TCustomChannel.Write(S: String = ''): Boolean; begin S := SetStr(S = '', DestinationData); Result := SetError(DoWrite(S)); end; // ===== TCustomChannel - open ========================================= procedure TCustomChannel.BeforeOpen; begin if Assigned(FOnBeforeOpen) then FOnBeforeOpen(Self); end; function TCustomChannel.DoOpen: Boolean; begin if Opened then Result := True else begin FHInet := InternetOpen(PChar(FUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, '', '', FFlags); Result := SetError(Opened); end; end; procedure TCustomChannel.AfterOpen; begin if Assigned(FOnOpened) then FOnOpened(Self); end; function TCustomChannel.Opened: Boolean; begin Result := (FHInet <> nil); end; function TCustomChannel.Open: Boolean; begin BeforeOpen; Result := DoOpen; if Result then AfterOpen; end; // ===== TCustomChannel - close ======================================== function TCustomChannel.CanClose: Boolean; var lCanClose: Boolean; begin lCanClose := True; if Assigned(FOnBeforeClose) then OnBeforeClose(Self, lCanClose); Result := lCanClose; end; function TCustomChannel.DoClose: Boolean; begin Result := Disconnect; if Result and Opened then Result := SetError(InternetCloseHandle(FHInet)); end; procedure TCustomChannel.AfterClose; begin if Assigned(FOnClosed) then FOnClosed(Self); end; function TCustomChannel.Closed: Boolean; begin Result := not Opened; end; function TCustomChannel.Close: Boolean; begin if Closed then Result := True else if not CanClose then Result := False else begin Result := DoClose; if Result then AfterClose; end; end; // ===== TCustomChannel - connect ====================================== procedure TCustomChannel.BeforeConnect; begin if Assigned(FOnBeforeConnect) then FOnBeforeConnect(Self); end; function TCustomChannel.DoConnect: Boolean; var lPI: TInternetProxyInfo; begin if Connected then Result := True else begin if UseProxy and ((Proxy <> '') or (ProxyBypass <> '')) then begin lPI.dwAccessType := INTERNET_OPEN_TYPE_PROXY; lPI.lpszProxy := PChar(Proxy); lPI.lpszProxyBypass := PChar(ProxyBypass); InternetSetOption(HInet, INTERNET_OPTION_PROXY, @lPI, SizeOf(lPI)); if ProxyNeedAuthorization and ((ProxyUser <> '') or (ProxyPassword <> '')) then begin InternetSetOption(HInet, INTERNET_OPTION_PROXY_USERNAME, PChar(ProxyUser), Length(ProxyUser)); InternetSetOption(HInet, INTERNET_OPTION_PROXY_PASSWORD, PChar(ProxyPassword), Length(ProxyPassword)); end; end else begin lPI.dwAccessType := INTERNET_OPEN_TYPE_PRECONFIG; lPI.lpszProxy := nil; lPI.lpszProxyBypass := nil; InternetSetOption(HInet, INTERNET_OPTION_PROXY, @lPI, SizeOf(lPI)); end; InternetSetOption(nil, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0); InternetSetOption(nil, INTERNET_OPTION_REFRESH , nil, 0); FHConnect := InternetConnect(HInet, PChar(FServerName), FServerPort, PChar(FUserName), PChar(FUserPassword), FServiceType, FFlags, 0); Result := SetError(Connected); end; end; procedure TCustomChannel.AfterConnect; begin if Assigned(FOnConnected) then FOnConnected(Self); end; function TCustomChannel.Connected: Boolean; begin Result := (FHConnect <> nil); end; function TCustomChannel.Connect(const ServerName: String = ''; const UserName: String = ''; const UserPassword: String = ''): Boolean; begin if ServerName <> '' then Self.ServerName := ServerName; if UserName <> '' then Self.UserName := UserName; if UserPassword <> '' then Self.UserPassword := UserPassword; BeforeConnect; Result := DoConnect; if Result then AfterConnect; end; // ===== TCustomChannel - disconnect =================================== function TCustomChannel.CanDisconnect: Boolean; var lCanDisconnect: Boolean; begin lCanDisconnect := True; if Assigned(FOnBeforeDisconnect) then OnBeforeDisconnect(Self, lCanDisconnect); Result := lCanDisconnect; end; function TCustomChannel.DoDisconnect: Boolean; begin if Disconnected then Result := True else Result := SetError(InternetCloseHandle(FHConnect)); end; procedure TCustomChannel.AfterDisconnect; begin if Assigned(FOnDisconnected) then FOnDisconnected(Self); end; function TCustomChannel.Disconnected: Boolean; begin Result := not Connected; end; function TCustomChannel.Disconnect: Boolean; begin if not CanDisconnect then Result := False else begin Result := DoDisconnect; if Result then AfterDisconnect; end; end; { THttpChannel } constructor THttpChannel.Create; begin inherited; FDataList := TStringList.Create; FServerPort := INTERNET_DEFAULT_HTTP_PORT; FServiceType := INTERNET_SERVICE_HTTP; end; destructor THttpChannel.Destroy; begin FDataList.Free; inherited; end; procedure THttpChannel.Assign(Channel: TCustomChannel); begin inherited Assign(Channel); if Channel is THttpChannel then DataList.Assign(THttpChannel(Channel).DataList) else DataList.Clear; end; function THttpChannel.CreateBoundary: String; var S: String; i: Integer; begin S := ''; for i := 0 to Pred(DataList.Count) do S := S + DataList[i]; repeat Result := ''; for i := 0 to 4 do Result := Result + Chr(Random(27) + Ord('A')) + Chr(Random(27) + Ord('a')); until Pos(Result, S) < 1; FBoundary := Result; end; function THttpChannel.GetDestinationData: String; var S: String; lCount: Integer; i: Integer; begin Result := ''; if DataList.Count > 0 then begin CreateBoundary; lCount := Pred(DataList.Count); for i := 0 to lCount do begin S := #13#10'--' + Boundary + #13#10 + DataList[i]; if i < lCount then Result := Result + S else Result := Result + S + #13#10'--' + Boundary + '--'#13#10; end; end; end; procedure THttpChannel.SetDestinationData(const Value: String); begin DataList.Clear; if Value <> '' then DataList.Add(Value); end; function THttpChannel.DoGetDataSize(out DataSize: Cardinal): Boolean; begin Result := InternetQueryDataAvailable(HRequest, DataSize, 0, 0); end; function THttpChannel.DoRead(DataSize: Cardinal; var S: String): Boolean; var lDataSize: Cardinal; lDataReaded: Cardinal; lTickCount: Cardinal; begin if DataSize = 0 then DataSize := Cardinal(-1); S := ''; lTickCount := GetTickCount; repeat Result := Open and Connect; if not Result then Close else begin Result := OpenRequest(HTTP_VERB_GET, INTERNET_FLAG_DONT_CACHE + INTERNET_FLAG_NO_COOKIES); if not Result then Close else begin Result := SendRequest('', ''); if not Result then Close else begin Result := GetDataSize(lDataSize) and (lDataSize > 511); if not Result then Close else if lDataSize = 0 then Result := True else begin if lDataSize > DataSize then lDataSize := DataSize; SetLength(S, lDataSize); Result := InternetReadFile(HRequest, @S[1], lDataSize, lDataReaded) and (lDataSize = lDataReaded); if not Result then Close else SetLength(S, lDataReaded); end; end; CloseRequest; end; end; if not Result then Sleep(500); until Result or IsTimeout(lTickCount, GetTickCount, Timeout); if not Result then FLastError := GetLastError; Close; end; function THttpChannel.DoWrite(const S: String): Boolean; var lReaded: Cardinal; lHeader: String; lTickCount: Cardinal; Stemp: String; begin lTickCount := GetTickCount; repeat Result := Open and Connect; if not Result then Close else begin Result := OpenRequest(HTTP_VERB_POST, INTERNET_FLAG_RELOAD); if not Result then Close else begin lHeader := 'Content-Type: multipart/form-data; boundary=' + Boundary + ''#13#10; Result := HttpAddRequestHeaders(FHRequest, PChar(lHeader), Length(lHeader), HTTP_ADDREQ_FLAG_REPLACE + HTTP_ADDREQ_FLAG_ADD); if not Result then Close else begin Result := SendRequest(lHeader, S); if not Result then Close else begin FReceivedData := ''; repeat SetLength(Stemp, 4096); Result := InternetReadFile(HRequest, @Stemp[1], 4096, lReaded); SetLength(Stemp, lReaded); FReceivedData := FReceivedData + Stemp; until not Result or (lReaded < 1); end; end; CloseRequest; end; end; if not Result then Sleep(500); until Result or IsTimeout(lTickCount, GetTickCount, Timeout); if not Result then FLastError := GetLastError; Close; end; function THttpChannel.OpenRequest(Verb: Integer; Flags: Cardinal; const ObjectName: String = ''): Boolean; var lVerb: PChar; begin if ObjectName <> '' then Self.ObjectName := ObjectName; case Verb of HTTP_VERB_POST: lVerb := 'POST'; HTTP_VERB_GET: lVerb := 'GET'; HTTP_VERB_HEAD: lVerb := 'HEAD'; HTTP_VERB_PUT: lVerb := 'PUT'; HTTP_VERB_LINK: lVerb := 'LINK'; HTTP_VERB_DELETE: lVerb := 'DELETE'; HTTP_VERB_UNLINK: lVerb := 'UNLINK'; else lVerb := 'GET'; end; FHRequest := HttpOpenRequest(HConnect, lVerb, PChar(FObjectName), 'HTTP/1.0', nil, nil, FFlags, 0); Result := SetError(FHRequest <> nil); end; function THttpChannel.SendRequest(const Header, Data: String): Boolean; begin Result := SetError(HttpSendRequest(HRequest, PChar(Header), Length(Header), PChar(Data), Length(Data))); end; function THttpChannel.CloseRequest: Boolean; begin Result := SetError(InternetCloseHandle(FHRequest)); end; function THttpChannel.AddDestinationData(const FieldName, FieldValue: String): String; var S: String; begin S := 'Content-Disposition: form-data; name="%s"'#13#10#13#10'%s'; DataList.Add(Format(S, [FieldName, FieldValue])); end; function THttpChannel.AddDestinationFile(const FieldName, FileName: String): String; var f: File; lReadCount: Integer; S, Stemp: String; begin Result := ''; if FileExists(FileName) then begin AssignFile(f, FileName); Reset(f, 1); try S := ''; repeat SetLength(Stemp, 2048); BlockRead(f, Stemp[1], 2048, lReadCount); SetLength(Stemp, lReadCount); S := S + Stemp; until Eof(f) or (lReadCount < 2048) finally CloseFile(f); end; if S <> '' then begin Stemp := 'Content-Disposition: form-data; name="%s"; filename="%s"'#13#10'Content-Type: application/octet-stream'#13#10#13#10'%s'; S := Format(Stemp, [FieldName, FileName, S]); DataList.Add(S); Result := DestinationData; end; end; end; end. Добавлено И вот кусок кода, который работает с каналом. Очень простой. procedure TConnector.SetElementValue(const AValue, AName: String); const lProcName = 'TConnector.SetElementValue'; begin if IsPageOpened then Channel.AddDestinationData(AName, AValue) else RaiseError(lProcName, PAGE_NOT_OPENED); end; procedure TConnector.Submit(const RequestToLog: TSimpleRequest); begin AddToLog(RequestToLog); Channel.Timeout := Timeout; FBreakByTimeout := not Channel.Write; Channel.DestinationData := ''; end; |