david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
678 lines
22 KiB
ObjectPascal
678 lines
22 KiB
ObjectPascal
unit uROWinInetHttpChannel;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up }
|
|
{ platform: Win32 }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the RemObjects SDK }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
{$I RemObjects.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
|
|
Classes, WinInet,
|
|
uRORes, uROClient, uROClientIntf, Windows;
|
|
|
|
const
|
|
DEFAULT_TIMEOUT = 1000 * 60 * 10; // default value = 10 Minutes
|
|
|
|
type
|
|
{ TLogin }
|
|
TROLogin = class(TPersistent)
|
|
private
|
|
fUsername,
|
|
fPassword: string;
|
|
public
|
|
procedure Assign(Source: TPersistent); override;
|
|
|
|
published
|
|
property Username:string read fUsername write fUsername;
|
|
property Password:string read fPassword write fPassword;
|
|
end;
|
|
|
|
TAfterAttemptConnectEvent = procedure (Sender: TObject; var aAttemptConnectResult: DWORD) of object;
|
|
{ TROWinINetHttpChannel }
|
|
TROWinInetHTTPChannel = class(TROTransportChannel, IROTransport, IROTCPTransport, IROHTTPTransport)
|
|
private
|
|
fUserAgent:string;
|
|
fTargetUrl:string;
|
|
fStoreConnected:boolean;
|
|
fKeepConnection:boolean;
|
|
|
|
fHeaders:string;
|
|
|
|
fInetConnect: HINTERNET;
|
|
fInetRoot: HINTERNET;
|
|
fUrlScheme: Integer;
|
|
fUrlHost: string;
|
|
fUrlSite: string;
|
|
fUrlPort: Integer;
|
|
fLogin: TROLogin;
|
|
fAfterConnect: TNotifyEvent;
|
|
fTrustInvalidCA: boolean; // True means disable check for valid SSL/PCT-based certificates.
|
|
fTimeOut: integer; // Request TimeOut value.
|
|
fAttemptToConnect: Boolean;
|
|
fInitializeAutoProxy: Boolean;
|
|
fOnAfterAttemptConnect: TAfterAttemptConnectEvent;
|
|
procedure SetConnected(iValue:boolean);
|
|
function GetConnected:boolean;
|
|
procedure SetLogin(const Value: TROLogin);
|
|
|
|
function SendData(iData:TStream):hInternet;
|
|
|
|
procedure Check(Error: Boolean);
|
|
procedure ReceiveData(iRequest:hInternet; ioData:TStream);
|
|
|
|
function AllowInvalidCA(InetConnect: HINTERNET; dwInetStatus: DWord): DWord;
|
|
function CheckInetError(InetConnect: HINTERNET; dwInetStatus: DWord): DWord;
|
|
protected
|
|
procedure IntDispatch(aRequest, aResponse : TStream); override;
|
|
procedure IntSetServerLocator(aServerLocator : TROServerLocator); override;
|
|
|
|
{ IROTransport }
|
|
function GetTransportObject : TObject; override;
|
|
|
|
{ IROTCPTransport }
|
|
function GetClientAddress : string;
|
|
|
|
{ IROHTTPTransport }
|
|
procedure SetHeaders(const aName, aValue : string);
|
|
function GetHeaders(const aName : string) : string;
|
|
function GetContentType : string;
|
|
procedure SetContentType(const aValue : string);
|
|
function GetUserAgent : string;
|
|
procedure SetUserAgent(const aValue : string);
|
|
|
|
procedure SetTargetURL(const Value: string);
|
|
function GetTargetURL:string;
|
|
|
|
function GetPathInfo : string;
|
|
function GetLocation : string;
|
|
function GetQueryString: String;
|
|
procedure SetPathInfo(const aValue: String);
|
|
|
|
procedure TriggerAfterConnect;
|
|
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure CheckProperties; override;
|
|
|
|
procedure Assign(aSource : TPersistent); override;
|
|
|
|
published
|
|
property UserAgent:string read GetUserAgent write SetUserAgent;
|
|
|
|
property TargetURL : string read fTargetURL write SetTargetURL;
|
|
property Login:TROLogin read fLogin write SetLogin;
|
|
property StoreConnected:boolean read fStoreConnected write fStoreConnected default false;
|
|
property Connected:boolean read GetConnected write SetConnected stored fStoreConnected default false;
|
|
property KeepConnection:boolean read fKeepConnection write fKeepConnection default false;
|
|
|
|
property Timeout: Integer read fTimeout write fTimeout default DEFAULT_TIMEOUT;
|
|
property AfterConnect:TNotifyEvent read fAfterConnect Write fAfterConnect;
|
|
property AttemptToConnect: Boolean read fAttemptToConnect write fAttemptToConnect default true;
|
|
property OnProgress;
|
|
property OnAfterAttemptConnect: TAfterAttemptConnectEvent read FOnAfterAttemptConnect write FOnAfterAttemptConnect;
|
|
property InitializeAutoProxy: Boolean read fInitializeAutoProxy write fInitializeAutoProxy default false;
|
|
published
|
|
property SynchronizedProbing;
|
|
property OnSendStream;
|
|
property OnReceiveStream;
|
|
property ServerLocators;
|
|
property DispatchOptions;
|
|
property OnServerLocatorAssignment;
|
|
property ProbeServers;
|
|
property ProbeFrequency;
|
|
property OnBeforeProbingServers;
|
|
property OnAfterProbingServers;
|
|
property OnBeforeProbingServer;
|
|
property OnAfterProbingServer;
|
|
property OnLoginNeeded;
|
|
end;
|
|
|
|
resourcestring
|
|
sxInvalidURLformat = 'Invalid URL format';
|
|
|
|
implementation
|
|
|
|
uses SysUtils, uROHTTPTools, uROClasses;
|
|
|
|
const
|
|
INTERNET_ERROR_MASK_COMBINED_SEC_CERT = $2;
|
|
const_WinInetErrorCode_MIN = INTERNET_ERROR_BASE + 1;
|
|
const_WinInetErrorCode_MAX = ERROR_INTERNET_FAILED_DUETOSECURITYCHECK;
|
|
|
|
ERROR_INTERNET_FORTEZZA_LOGIN_NEEDED = (INTERNET_ERROR_BASE + 54);
|
|
ERROR_INTERNET_SEC_CERT_ERRORS = (INTERNET_ERROR_BASE + 55);
|
|
ERROR_INTERNET_SEC_CERT_NO_REV = (INTERNET_ERROR_BASE + 56);
|
|
ERROR_INTERNET_SEC_CERT_REV_FAILED = (INTERNET_ERROR_BASE + 57);
|
|
|
|
{ TROWinINetHTTPChannel }
|
|
|
|
procedure TROWinINetHTTPChannel.Check(Error: Boolean);
|
|
var ErrCode:integer;
|
|
S:string;
|
|
begin
|
|
ErrCode := getlasterror;
|
|
if Error and (ErrCode <> 0) then begin
|
|
SetLength(S, 256);
|
|
if FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(GetModuleHandle('wininet.dll')), ErrCode, 0, PChar(S), Length(S), nil) > 0 then begin;
|
|
SetLength(S, StrLen(PChar(S)));
|
|
while (Length(S) > 0) and (S[Length(S)] in [#10, #13]) do SetLength(S, Length(S) - 1);
|
|
raise EROException.Create(S);
|
|
end
|
|
else begin
|
|
raise EROException.CreateFmt(err_UnexpectedWinINetProblem,[ErrCode]);
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
constructor TROWinInetHTTPChannel.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
fTimeOut := DEFAULT_TIMEOUT;
|
|
UserAgent := str_ProductName;
|
|
fLogin := TROLogin.Create();
|
|
fAttemptToConnect := true;
|
|
end;
|
|
|
|
destructor TROWinInetHTTPChannel.Destroy;
|
|
begin
|
|
Connected := false;
|
|
FreeAndNil(fLogin);
|
|
inherited;
|
|
end;
|
|
|
|
function TROWinInetHTTPChannel.GetConnected: boolean;
|
|
begin
|
|
result := Assigned(fInetConnect);
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.GetContentType: string;
|
|
begin
|
|
result := GetHeaders(id_ContentType);
|
|
end;
|
|
|
|
procedure TROWinINetHTTPChannel.SetContentType(const aValue: string);
|
|
begin
|
|
SetHeaders(id_ContentType,aValue);
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.GetHeaders(const aName: string): string;
|
|
begin
|
|
end;
|
|
|
|
procedure TROWinINetHTTPChannel.SetHeaders(const aName, aValue: string);
|
|
begin
|
|
if aValue = '' then exit;
|
|
if fHeaders <> '' then fHeaders := fHeaders+#13#10;
|
|
fHeaders := fHeaders+aName+': '+aValue;
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.GetClientAddress: string;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.GetLocation: string;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.GetPathInfo: string;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.GetTargetURL: string;
|
|
begin
|
|
result := fTargetUrl;
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.GetUserAgent: string;
|
|
begin
|
|
result := fUserAgent;
|
|
end;
|
|
|
|
procedure TROWinINetHTTPChannel.SetUserAgent(const aValue: string);
|
|
begin
|
|
if UserAgent <> aValue then
|
|
fUserAgent := aValue;
|
|
end;
|
|
|
|
procedure TROWinInetHTTPChannel.SetLogin(const Value: TROLogin);
|
|
begin
|
|
fLogin.Assign(Value);
|
|
end;
|
|
|
|
procedure TROWinINetHTTPChannel.IntDispatch(aRequest, aResponse: TStream);
|
|
var lRequest:hInternet;
|
|
begin
|
|
CheckProperties;
|
|
Connected := true;
|
|
try
|
|
lRequest := SendData(aRequest);
|
|
try
|
|
ReceiveData(lRequest,aResponse);
|
|
finally
|
|
InternetCloseHandle(lRequest);
|
|
end;
|
|
finally
|
|
if not KeepConnection then Connected := false;
|
|
end;
|
|
end;
|
|
|
|
function TROWinINetHTTPChannel.SendData(iData: TStream):hInternet;
|
|
var
|
|
lHeaders: string;
|
|
RetVal, Flags: DWord;
|
|
AcceptTypes: array of PChar;
|
|
lDataStream: TMemoryStream;
|
|
Mask: DWORD;
|
|
bRes: Boolean;
|
|
begin
|
|
SetLength(AcceptTypes, 2);
|
|
|
|
TriggerProgress(ptStart, pdSending, 0, iData.Size);
|
|
|
|
AcceptTypes[0] := PChar('application/octet-stream');
|
|
AcceptTypes[1] := nil;
|
|
|
|
Flags := INTERNET_FLAG_NO_CACHE_WRITE;
|
|
|
|
if KeepConnection then Flags := Flags or INTERNET_FLAG_KEEP_CONNECTION;
|
|
if fURLScheme = INTERNET_SCHEME_HTTPS then begin
|
|
Flags := Flags or INTERNET_FLAG_SECURE;
|
|
if fTrustInvalidCA then begin
|
|
Flags := Flags or INTERNET_FLAG_IGNORE_CERT_CN_INVALID
|
|
or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID;
|
|
end;
|
|
end;
|
|
|
|
result := HttpOpenRequest(FInetConnect, 'POST', PChar(fURLSite), nil, nil, Pointer(AcceptTypes), Flags, Integer(Self));
|
|
Check(not Assigned(result));
|
|
|
|
{ Time Out }
|
|
if fTimeOut > 0 then begin
|
|
InternetSetOption(Result, INTERNET_OPTION_RECEIVE_TIMEOUT, @fTimeOut, SizeOf(fTimeOut));
|
|
InternetSetOption(FInetConnect, INTERNET_OPTION_RECEIVE_TIMEOUT, @fTimeOut, SizeOf(fTimeOut));
|
|
|
|
InternetSetOption(Result, INTERNET_OPTION_SEND_TIMEOUT, @fTimeOut, SizeOf(fTimeOut));
|
|
InternetSetOption(FInetConnect, INTERNET_OPTION_SEND_TIMEOUT, @fTimeOut, SizeOf(fTimeOut));
|
|
end;
|
|
|
|
{ Sertificates Errors }
|
|
Mask := INTERNET_ERROR_MASK_COMBINED_SEC_CERT;
|
|
InternetSetOption(FInetConnect, INTERNET_OPTION_ERROR_MASK, @Mask, SizeOf(Mask));
|
|
|
|
if iData is TMemoryStream then begin
|
|
lDataStream := iData as TMemoryStream
|
|
end
|
|
else begin
|
|
lDataStream := TMemoryStream.Create();
|
|
lDataStream.LoadFromStream(iData);
|
|
end;
|
|
|
|
try
|
|
|
|
while true do begin
|
|
lHeaders := fHeaders;
|
|
fHeaders := '';
|
|
bRes := HttpSendRequest(Result, pChar(lHeaders), Length(lHeaders), lDataStream.Memory, lDataStream.Size);
|
|
if not bRes then begin
|
|
RetVal := GetLastError;
|
|
if (RetVal > const_WinInetErrorCode_MIN) and (RetVal < const_WinInetErrorCode_MAX) then begin
|
|
if (RetVal = ERROR_INTERNET_SEC_CERT_ERRORS) or
|
|
(RetVal = ERROR_INTERNET_INVALID_CA) or
|
|
(RetVal = ERROR_INTERNET_SEC_CERT_CN_INVALID) or
|
|
(RetVal = ERROR_INTERNET_SEC_CERT_DATE_INVALID) or
|
|
(RetVal = ERROR_INTERNET_SEC_CERT_REV_FAILED) then begin
|
|
RetVal := AllowInvalidCA(Result, RetVal);
|
|
bRes := True;
|
|
end else if (RetVal = ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED) then begin
|
|
{ you are accessing Secure Socket Layer (SSL)-protected resource
|
|
on a Web server that requires a valid client certificate. }
|
|
RetVal := CheckInetError(Result, RetVal);
|
|
bRes := True;
|
|
end else if (RetVal = HTTP_STATUS_DENIED)
|
|
or (RetVal = HTTP_STATUS_PAYMENT_REQ) then begin
|
|
RetVal := CheckInetError(Result, RetVal);
|
|
bRes := True;
|
|
end;
|
|
end;
|
|
end else begin
|
|
RetVal := CheckInetError(Result, GetLastError);
|
|
end;
|
|
Check(not bRes);
|
|
case RetVal of
|
|
ERROR_SUCCESS: begin
|
|
SetLastError(ERROR_SUCCESS);
|
|
Break;
|
|
end;
|
|
ERROR_CANCELLED: SysUtils.Abort;
|
|
ERROR_INTERNET_FORCE_RETRY: {Retry the operation};
|
|
end;
|
|
end;
|
|
|
|
finally
|
|
if lDataStream <> iData then lDataStream.Free;
|
|
end;
|
|
|
|
TriggerProgress(ptDone, pdSending, 0, iData.Size);
|
|
|
|
end;
|
|
|
|
procedure TROWinInetHTTPChannel.ReceiveData(iRequest:hInternet; ioData:TStream);
|
|
const MaxStatusText : Integer = 4096;
|
|
var
|
|
Size, Status, Len, Index: DWord;
|
|
S:string;
|
|
|
|
lpszData: PChar; // buffer for the data
|
|
dwSize: DWORD; // size of the data available
|
|
dwDownloaded: DWORD; // size of the downloaded data
|
|
|
|
lTotalSize,lReceivedSize:dword;
|
|
begin
|
|
Len := SizeOf(Status);
|
|
Index := 0;
|
|
|
|
{ Get Status Code }
|
|
if not HttpQueryInfo(iRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER,
|
|
@Status, Len, Index) then RaiseLastOSError();
|
|
|
|
{ Throw Exception is StatusCode >= 300 BUT not 500. SOAP faulty envelopes comes with that set }
|
|
if (Status >= 300) and (Status <> 500) then begin
|
|
Index := 0;
|
|
Size := MaxStatusText;
|
|
SetLength(S, Size);
|
|
if HttpQueryInfo(iRequest, HTTP_QUERY_STATUS_TEXT, @S[1], Size, Index) then begin
|
|
SetLength(S, Size);
|
|
raise EROException.CreateFmt('%s (%d)', [S, Status]);
|
|
end;
|
|
end;
|
|
|
|
Index := 0;
|
|
{ get total size }
|
|
if not HttpQueryInfo(iRequest, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, @lTotalSize, Len, Index) then begin
|
|
{ do not raise an exception when there is no "Content-Length" value in result header }
|
|
if GetLastError <> ERROR_HTTP_HEADER_NOT_FOUND then begin
|
|
RaiseLastOSError(); //TotalSize = 0;//
|
|
end else begin
|
|
SetLastError(0);
|
|
lTotalSize := 0;
|
|
end;
|
|
end;
|
|
|
|
TriggerProgress(ptStart, pdReceiving, 0, lTotalSize);
|
|
|
|
lReceivedSize := 0;
|
|
dwSize := 0;
|
|
dwDownloaded := 0;
|
|
while (true) do begin
|
|
// The call to InternetQueryDataAvailable determines the amount of data available to download.
|
|
while (not InternetQueryDataAvailable(iRequest, dwSize, 0, 0))
|
|
and (GetLastError = ERROR_IO_PENDING) do begin
|
|
Sleep(1);
|
|
end;
|
|
|
|
// Allocates a buffer of the size returned by InternetQueryDataAvailable
|
|
GetMem(lpszData, dwSize + 1);
|
|
try
|
|
// Reads the data from the HINTERNET handle.
|
|
while (not InternetReadFile(iRequest, lpszData, dwSize, dwDownloaded))
|
|
and (GetLastError = ERROR_IO_PENDING) do begin
|
|
Sleep(1);
|
|
end;
|
|
if (GetLastError >= const_WinInetErrorCode_MIN) and (GetLastError <= const_WinInetErrorCode_MAX) then begin
|
|
Check(True);
|
|
end;
|
|
if GetLastError <> 0 then begin
|
|
// Adds a null terminator to the end of the data buffer
|
|
lpszData[dwDownloaded] := #0;
|
|
end;
|
|
|
|
ioData.Write(PChar(lpszData)^, dwDownloaded);
|
|
Inc(lReceivedSize, dwDownloaded);
|
|
finally
|
|
FreeMem(lpszData);
|
|
end;
|
|
|
|
TriggerProgress(ptInProgress, pdReceiving, lReceivedSize, lTotalSize);
|
|
|
|
// Check the size of the remaining data. If it is zero, break.
|
|
if (dwDownloaded = 0) then begin
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
ioData.seek(0, soFromBeginning);
|
|
|
|
TriggerProgress(ptDone, pdReceiving, 0,0);
|
|
end;
|
|
|
|
function TROWinInetHTTPChannel.AllowInvalidCA(InetConnect: HINTERNET; dwInetStatus: DWord): DWord;
|
|
var
|
|
dwError: integer;
|
|
lppvData: pointer;
|
|
SECURITY_FLAGS: integer;
|
|
lpszDataSize: cardinal;
|
|
CertRevocation: boolean;
|
|
BRes: Boolean;
|
|
begin
|
|
Result := ERROR_CANCELLED;
|
|
if (dwInetStatus = ERROR_INTERNET_SEC_CERT_ERRORS) or
|
|
(dwInetStatus = ERROR_INTERNET_INVALID_CA) or
|
|
(dwInetStatus = ERROR_INTERNET_SEC_CERT_CN_INVALID) or
|
|
(dwInetStatus = ERROR_INTERNET_SEC_CERT_DATE_INVALID) or
|
|
(dwInetStatus = ERROR_INTERNET_SEC_CERT_REV_FAILED) then begin
|
|
CertRevocation := (dwInetStatus = ERROR_INTERNET_SEC_CERT_REV_FAILED);
|
|
if CertRevocation or not fTrustInvalidCA then begin
|
|
dwError := InternetErrorDlg(GetDesktopWindow(), InetConnect, dwInetStatus,
|
|
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
|
|
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, lppvData);
|
|
bRes := (dwError = ERROR_INTERNET_FORCE_RETRY) or (dwError = ERROR_SUCCESS);
|
|
end else begin
|
|
bRes := True;
|
|
end;
|
|
if bRes then begin
|
|
try
|
|
InternetQueryOption(InetConnect, INTERNET_OPTION_SECURITY_FLAGS, @SECURITY_FLAGS, lpszDataSize);
|
|
if CertRevocation then begin
|
|
SECURITY_FLAGS := SECURITY_FLAGS or SECURITY_FLAG_IGNORE_REVOCATION;
|
|
end else begin
|
|
SECURITY_FLAGS := SECURITY_FLAGS or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
|
|
or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID
|
|
or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
|
|
end;
|
|
InternetSetOption(InetConnect, INTERNET_OPTION_SECURITY_FLAGS, @SECURITY_FLAGS, lpszDataSize);
|
|
except
|
|
dwError := InternetErrorDlg(GetDesktopWindow(), InetConnect, dwInetStatus,
|
|
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
|
|
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, lppvData);
|
|
bRes := (dwError = ERROR_INTERNET_FORCE_RETRY) or (dwError = ERROR_SUCCESS);
|
|
end;
|
|
end;
|
|
if not CertRevocation then begin
|
|
FTrustInvalidCA := bRes;
|
|
end;
|
|
if bRes then begin
|
|
Result := ERROR_INTERNET_FORCE_RETRY;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROWinInetHTTPChannel.CheckInetError(InetConnect: HINTERNET; dwInetStatus: DWord): DWord;
|
|
var
|
|
lppvData: pointer;
|
|
begin
|
|
Result := InternetErrorDlg(GetDesktopWindow(), InetConnect, dwInetStatus,
|
|
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS or
|
|
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA, lppvData);
|
|
end;
|
|
|
|
procedure TROWinInetHTTPChannel.TriggerAfterConnect;
|
|
begin
|
|
if Assigned(AfterConnect) then AfterConnect(self);
|
|
end;
|
|
|
|
|
|
function InternetInitializeAutoProxyDll(dwReserved: DWord): LongBool; stdcall; external 'WinInet.dll';
|
|
var
|
|
AutoProxyCalled: Boolean = False;
|
|
|
|
procedure TROWinInetHTTPChannel.SetConnected(iValue: boolean);
|
|
var
|
|
lAccessType:Integer;
|
|
lAttemptConnect: DWORD;
|
|
begin
|
|
if iValue and not GetConnected then begin
|
|
|
|
{if Length(Proxy) > 0 then
|
|
AccessType := INTERNET_OPEN_TYPE_PROXY
|
|
else}
|
|
lAccessType := INTERNET_OPEN_TYPE_PRECONFIG;
|
|
|
|
if fInitializeAutoProxy then begin
|
|
if not AutoProxyCalled then begin
|
|
InternetInitializeAutoProxyDll(0);
|
|
AutoProxyCalled := true;
|
|
end;
|
|
end;
|
|
|
|
|
|
fInetRoot := InternetOpen(PChar(UserAgent), lAccessType, nil, nil, 0);//PChar(Proxy)}, PChar(ProxyByPass), 0);
|
|
|
|
if fAttemptToConnect then begin
|
|
lAttemptConnect := InternetAttemptConnect(0);
|
|
if assigned(FOnAfterAttemptConnect) then
|
|
FOnAfterAttemptConnect(self, lAttemptConnect);
|
|
if lAttemptConnect <> ERROR_SUCCESS then SysUtils.Abort;
|
|
end;
|
|
|
|
Check(not Assigned(FInetRoot));
|
|
try
|
|
FInetConnect := InternetConnect(FInetRoot, PChar(FURLHost), FURLPort, PChar(Login.UserName), PChar(Login.Password), INTERNET_SERVICE_HTTP, 0, Cardinal(Self));
|
|
Check(not Assigned(FInetConnect));
|
|
TriggerAfterConnect();
|
|
except
|
|
InternetCloseHandle(FInetRoot);
|
|
FInetRoot := nil;
|
|
raise;
|
|
end;
|
|
end
|
|
else if not iValue then begin
|
|
if Assigned(FInetConnect) then InternetCloseHandle(FInetConnect);
|
|
FInetConnect := nil;
|
|
if Assigned(FInetRoot) then InternetCloseHandle(FInetRoot);
|
|
FInetRoot := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TROWinINetHTTPChannel.SetTargetURL(const Value: string);
|
|
var URLComp:TURLComponents;
|
|
p:PChar;
|
|
begin
|
|
if Targeturl <> Value then begin
|
|
fTargetUrl := Value;
|
|
|
|
if fTargetUrl <> '' then begin
|
|
FillChar(URLComp, SizeOf(URLComp), 0);
|
|
URLComp.dwStructSize := SizeOf(URLComp);
|
|
URLComp.dwSchemeLength := 1;
|
|
URLComp.dwHostNameLength := 1;
|
|
URLComp.dwURLPathLength := 1;
|
|
InternetCrackUrl(PChar(fTargetUrl), 0, 0, URLComp);
|
|
if not (URLComp.nScheme in [INTERNET_SCHEME_HTTP, INTERNET_SCHEME_HTTPS]) then
|
|
raise EROException.Create(sxInvalidURLformat);
|
|
FURLScheme := URLComp.nScheme;
|
|
FURLPort := URLComp.nPort;
|
|
p := PChar(fTargetUrl);
|
|
FURLHost := Copy(fTargetUrl, URLComp.lpszHostName - p + 1, URLComp.dwHostNameLength);
|
|
FURLSite := Copy(fTargetUrl, URLComp.lpszUrlPath - p + 1, URLComp.dwURLPathLength);
|
|
end
|
|
else begin
|
|
fURLPort := 0;
|
|
fURLHost := '';
|
|
fURLSite := '';
|
|
fURLScheme := 0;
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
function TROWinInetHTTPChannel.GetTransportObject: TObject;
|
|
begin
|
|
result := self;
|
|
end;
|
|
|
|
procedure TROWinInetHTTPChannel.IntSetServerLocator(aServerLocator: TROServerLocator);
|
|
begin
|
|
TargetURL := aServerLocator.Host;
|
|
end;
|
|
|
|
function TROWinInetHTTPChannel.GetQueryString: String;
|
|
begin
|
|
result := ''
|
|
end;
|
|
|
|
procedure TROWinInetHTTPChannel.SetPathInfo(const aValue: String);
|
|
begin
|
|
// do nothing
|
|
end;
|
|
|
|
procedure TROWinInetHTTPChannel.CheckProperties;
|
|
begin
|
|
uROClasses.Check(TargetURL = '', Name + '.TargetURL must be set.');
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROWinInetHTTPChannel.Assign(aSource: TPersistent);
|
|
var
|
|
lSource: TROWinInetHTTPChannel;
|
|
begin
|
|
inherited;
|
|
|
|
if (aSource is TROWinInetHTTPChannel) then begin
|
|
lSource := TROWinInetHTTPChannel(aSource);
|
|
|
|
UserAgent := lSource.UserAgent;
|
|
TargetURL := lSource.TargetURL;
|
|
Login.Assign(lSource.Login);
|
|
StoreConnected := lSource.StoreConnected;
|
|
Connected := lSource.Connected;
|
|
KeepConnection := lSource.KeepConnection;
|
|
AfterConnect := lSource.AfterConnect;
|
|
OnProgress := lSource.OnProgress;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TROLogin }
|
|
|
|
procedure TROLogin.Assign(Source: TPersistent);
|
|
begin
|
|
if (Source is TROLogin) then begin
|
|
Username := TROLogin(Source).Username;
|
|
Password := TROLogin(Source).Password;
|
|
end
|
|
else inherited;
|
|
end;
|
|
|
|
initialization
|
|
RegisterTransportChannelClass(TROWinInetHTTPChannel);
|
|
|
|
finalization
|
|
UnRegisterTransportChannelClass(TROWinInetHTTPChannel);
|
|
end.
|