Форум на Исходниках.RU

{==============================================================================

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('');

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;

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;

// ===== 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;

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;

{ 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;

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

else

begin

Result := OpenRequest(HTTP_VERB_GET, INTERNET_FLAG_DONT_CACHE + INTERNET_FLAG_NO_COOKIES);

if not Result then

else

begin

Result := SendRequest('', '');

if not Result then

else

begin

Result := GetDataSize(lDataSize) and (lDataSize > 511);

if not Result then

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

else

SetLength(S, lDataReaded);

end;

CloseRequest;

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

else

begin

Result := OpenRequest(HTTP_VERB_POST, INTERNET_FLAG_RELOAD);

if not Result then

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

else

begin

Result := SendRequest(lHeader, S);

if not Result then

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;

CloseRequest;

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.