Wininet请求包装类简稿
unit uWnWinetClass;
interface
uses
Windows,Messages,SysUtils,Classes,WinInet;
const
CONST_AGENT = 'Wininet by Enli';
BUFFER_SIZE = 4096;
type
//定义http的请求调用方式
//TWinWrapVerbs = (wwvGET, wwvPOST, wwvMPOST);
//定义协议版本
TWinHttpVersion = (wwvHttp1,wwvHttp11);
//错误类型，没有错误为wwecNil
TWinInetErrorCauses = (wwecNil, //0
wwecAttemptConnect, //1
wwecOpen, //2
wwecConnect, //3
wwecOpenRequest, //4
wwecConfigureRequest, //5
wwecExecRequest, //6
wwecEndRequest, //7
wwecTimeOut, //8
wwecUPD, //9
wwecAbort, //10
wwecStatus, //11
wwecHeader, //12
wwecContentLength, //13
wwecContentType, //14
wwecReadFile, //15
wwecWriteFile); //16
TProxyInfo = record
FProxyType : Integer; //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
FProxyServer : string;
FProxyPort : Integer;
FProxyUserName : string;
FProxyUserPass : string;
end;
TWnWinetClass = class
private
FNet: HINTERNET;
FRequest: HINTERNET;
FSession: HINTERNET;
FRequestStream: TMemoryStream;
FResponseStream: TMemoryStream;
FVerb: string;
FAbort: Boolean;
FWininetStateChanged: Boolean;
FTimeOut: Integer;
FSecure: Boolean;
FProxyInfo: TProxyInfo;
FServerPort: Integer;
FEncodeUrl: string;
FErrInfo: string;
FServerPass: string;
FServerUser: string;
FServerName: string;
FProxy : string;
FHttpHeader: string;
FData: array [0 .. BUFFER_SIZE] of Char;
FErrorCause: TWinInetErrorCauses;
FHttpVersion: TWinHttpVersion;
FStatus: integer;
FContentType: string;
FContentLength: Int64;
FTotal: Int64;
FResponseHeader: string;
procedure SetAbort(const Value: Boolean);
procedure FixServerInfo;
procedure FixProxyServerInfo;
function OpenConnection: Boolean;
function OpenRequest: Boolean;
function ConfigureRequest: Boolean;
function PerformMethod: Boolean;
function DetectProxyServer: DWORD;
function PortToUse(APort: Integer): Integer;
function FetchHeader(AFlags: integer): Boolean;
function ReadResponse: Boolean; // 读取接受数据
function ReadResponseHeader: Boolean; //获取返回数据包头
function FixContentLength: Boolean; // 获取接受数据的大小
function FixContentType: Boolean; // 获取接受数据的类型
function FixWinINetError(AError: integer): string;
function GetHttpVersion: string;
procedure AssignError(AError: TWinInetErrorCauses);
public
constructor Create;
destructor Destroy; override;
property Abort: Boolean read FAbort write SetAbort;
property Response: TMemoryStream read FResponseStream;
property HttpVersion: TWinHttpVersion read FHttpVersion write FHttpVersion;
property ServerName: string read FServerName write FServerName;
property ServerPort: Integer read FServerPort write FServerPort;
property ServerUser: string read FServerUser write FServerUser;
property ServerPass: string read FServerPass write FServerPass;
property ProxyInfo: TProxyInfo read FProxyInfo write FProxyInfo;
property HttpHeader: string read FHttpHeader write FHttpHeader;
property ResponseHeader: string read FResponseHeader write FResponseHeader;
property Status: Integer read FStatus;
property ContentLength: Int64 read FContentLength;
property Total: Int64 read FTotal;
property ErrInfo: string read FErrInfo;
property ErrorCause: TWinInetErrorCauses read FErrorCause;
procedure CleanUp(isAll: Boolean);
function HttpGet(isUrl:string;iiTimeout:Integer;ASecure:Boolean = False):boolean;
function HttpPost(isUrl:string;AStream:TMemoryStream;iiTimeout:Integer;ASecure:Boolean = False):boolean;
class function StreamToHex(AStream: TMemoryStream): string;
class procedure HexToStream(AStream: TMemoryStream;AHex: string);
end;
implementation
{ TWnWinetClass }
procedure TWnWinetClass.AssignError(AError: TWinInetErrorCauses);
var
I, H: Integer;
LTemp: string;
LR: Cardinal;
begin
FErrorCause := AError;
if Length(FErrInfo) = 0 then
begin
LR := GetLastError;
if (LR < 12000) or (LR < 12175) then
begin
H := GetModuleHandle('wininet.dll');
SetLength(LTemp, 256);
I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), LR, 0,
PChar(LTemp), 256, nil);
SetLength(LTemp, I);
FErrInfo := 'Error '+IntTostr(LR)+':'+LTemp;
end
else
FErrInfo := 'Error '+IntTostr(LR)+':'+SysErrorMessage(GetLastError);
end;
end;
procedure TWnWinetClass.CleanUp(isAll: Boolean);
begin
if isAll then
begin
if Assigned(FRequest) then
begin
InternetCloseHandle(FRequest);
FRequest := nil;
end;
if Assigned(FSession) then
begin
InternetCloseHandle(FSession);
FSession := nil;
end;
if Assigned(FNet) then
begin
InternetCloseHandle(FNet);
FNet := nil;
end;
end;
//FResponse.Clear;
SetLength(FProxy,0);
end;
function TWnWinetClass.ConfigureRequest: Boolean;
function SetUPD(AOption: DWORD; AUPD: PChar): Boolean;
begin
Result := (Length(AUPD) = 0) or InternetSetOption
(FRequest, AOption, AUPD, Length(AUPD));
end;
begin
Result := False;
if FAbort then
Exit;
// 设置HTTP头
{if FFileSize > 0 then
begin
if Length(FHttpHeader) > 0 then
FHttpHeader := FHttpHeader + #13#10'Range: bytes=' + IntTostr(FFileSize)
+ '-'#13#10
else
FHttpHeader := 'Range: bytes=' + IntTostr(FFileSize) + '-'#13#10;
end;}
if Length(FHttpHeader) > 0 then
begin
Result := HttpAddRequestHeaders(FRequest, PWideChar(FHttpHeader), Cardinal
(-1), HTTP_ADDREQ_FLAG_ADD or HTTP_ADDREQ_FLAG_REPLACE);
if not Result then
begin
AssignError(wwecConfigureRequest);
Exit;
end;
end;
// 设置超时
if (FTimeOut < 1) or (FTimeOut > 999) then
FTimeOut := 30;
FTimeOut := FTimeOut * 1000;
Result := InternetSetOption(FNet, INTERNET_OPTION_CONNECT_TIMEOUT, @FTimeOut,
SizeOf(integer)) and InternetSetOption
(FNet, INTERNET_OPTION_RECEIVE_TIMEOUT, @FTimeOut, SizeOf(integer))
and InternetSetOption(FNet, INTERNET_OPTION_SEND_TIMEOUT, @FTimeOut, SizeOf
(integer));
if not(Result) then
begin
AssignError(wwecTimeOut);
Exit;
end;
// 设置代理用户密码，访问用户密码
if SetUPD(INTERNET_OPTION_PROXY_USERNAME, PChar(FProxyInfo.FProxyUserName))
and SetUPD(INTERNET_OPTION_PROXY_PASSWORD, PChar(FProxyInfo.FProxyUserPass)
) and SetUPD(INTERNET_OPTION_USERNAME, PChar(FServerPass)) and SetUPD
(INTERNET_OPTION_PASSWORD, PChar(FServerUser)) then
else
AssignError(wwecUPD);
end;
constructor TWnWinetClass.Create;
begin
inherited;
FResponseStream := TMemoryStream.Create;
FRequest := nil;
FSession := nil;
FRequestStream := nil;
FNet := nil;
FAbort := False;
FSecure := False;
FWininetStateChanged := False;
SetLength(FEncodeUrl,0);
SetLength(FErrInfo,0);
SetLength(FServerUser,0);
SetLength(FServerPass,0);
SetLength(FProxy,0);
FVerb := 'GET';
end;
destructor TWnWinetClass.Destroy;
begin
FResponseStream.Free;
inherited;
end;
function TWnWinetClass.DetectProxyServer: DWORD;
begin
//-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
//Result:
//INTERNET_OPEN_TYPE_PRECONFIG 0
//INTERNET_OPEN_TYPE_DIRECT 1
//INTERNET_OPEN_TYPE_PROXY 3
//INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY 4
with FProxyInfo do
case (FProxyType-1) of
0: Result := INTERNET_OPEN_TYPE_DIRECT;
1:
begin
Result := INTERNET_OPEN_TYPE_PROXY;
FProxy := Format('socks=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
end;
2:
begin
Result := INTERNET_OPEN_TYPE_PROXY;
FProxy := Format('socks5=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
end;
3:
begin
Result := INTERNET_OPEN_TYPE_PROXY;
FProxy := Format('%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
end;
else
Result := INTERNET_OPEN_TYPE_PRECONFIG;
end;
end;
function TWnWinetClass.FetchHeader(AFlags: integer): Boolean;
var
BufLen, Index: DWORD;
begin
Result := False;
if FAbort then Exit;
Index := 0;
BufLen := BUFFER_SIZE;
FillChar(FData, BufLen, 0);
Result := HttpQueryInfo(FRequest, AFlags, @FData, BufLen, Index);
end;
function TWnWinetClass.FixContentLength: Boolean;
var
LTemp: string;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_CONTENT_LENGTH);
LTemp := FData;
if Result then
FContentLength := StrToInt64Def(LTemp, 0)
else
AssignError(wwecContentLength);
end;
function TWnWinetClass.FixContentType: Boolean;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_CONTENT_TYPE);
if Result then
FContentType := FData
else
AssignError(wwecContentType);
end;
procedure TWnWinetClass.FixProxyServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
ls1ServerName := LowerCase(FServerName);
liLoc := Pos(':', ls1ServerName);
if liLoc = 0 then Exit;
lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
FServerName := PChar(Copy(ls1ServerName, 1, liLoc - 1));
FServerPort := StrToIntDef(lsPort,FServerPort);
end;
procedure TWnWinetClass.FixServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
if FProxyInfo.FProxyType = 0 then Exit;
ls1ServerName := LowerCase(FProxyInfo.FProxyServer);
liLoc := Pos(':', ls1ServerName);
if liLoc = 0 then Exit;
lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
FProxyInfo.FProxyServer := PChar(Copy(ls1ServerName, 1, liLoc - 1));
FProxyInfo.FProxyPort := StrToIntDef(lsPort,FProxyInfo.FProxyPort);
end;
function TWnWinetClass.FixWinINetError(AError: integer): string;
begin
//Result := 'Http Status: ' + IntTostr(AError);
if FetchHeader(HTTP_QUERY_STATUS_TEXT) then
Result := FData
//if not Result then
else
begin
AssignError(wwecStatus);
Exit;
end;
end;
function TWnWinetClass.GetHttpVersion: string;
begin
if FHttpVersion = wwvHttp1 then
Result := 'HTTP/1.0'
else
Result := 'HTTP/1.1';
end;
class procedure TWnWinetClass.HexToStream(AStream: TMemoryStream;AHex: string);
var
I,iLen: Integer;
LTemp: string;
LB : Byte;
begin
iLen := Length(AHex);
if (iLen mod 3) <> 0 then
begin
Assert(False,'hex字符串错误');
Exit;
end;
for I := 0 to (iLen div 3) - 1 do
begin
LTemp := Copy(AHex,I*3+1,2);
LB := StrToIntDef('$'+LTemp,0);
AStream.WriteBuffer(Lb,1);
//Assert(Pos(IntToStr(LB),LTemp)=0,'asdf');
end;
end;
function TWnWinetClass.HttpGet(isUrl: string; iiTimeout: integer;
ASecure: Boolean): boolean;
begin
FVerb := 'GET';
FRequest := nil;
FRequestStream := nil;
SetLastError(0);
FErrInfo := '';
FErrorCause := wwecNil;
Result := False;
FEncodeUrl := isUrl;
FTimeOut := iiTimeout;
FSecure := ASecure;
FixServerInfo;
FixProxyServerInfo;
Result := OpenConnection
and OpenRequest
and ConfigureRequest
and PerformMethod;
CleanUp(True);
end;
function TWnWinetClass.HttpPost(isUrl: string; AStream: TMemoryStream;
iiTimeout: Integer; ASecure: Boolean): boolean;
begin
FVerb := 'POST';
FRequestStream := AStream;
SetLastError(0);
FErrInfo := '';
FErrorCause := wwecNil;
Result := False;
FEncodeUrl := isUrl;
FTimeOut := iiTimeout;
FSecure := ASecure;
FixServerInfo;
FixProxyServerInfo;
Result := OpenConnection
and OpenRequest
and ConfigureRequest
and PerformMethod;
CleanUp(True);
end;
function TWnWinetClass.OpenConnection: Boolean;
var
LProxyType: DWORD;
function WW_AttemptConnect: Boolean;
begin
Result := (CompareText(FServerName, 'localhost') = 0) or
(InternetAttemptConnect(0) = ERROR_SUCCESS);
if not (Result) then AssignError(wwecAttemptConnect);
end;
procedure CancelMaxConnectLimite();
var
liPerServer1, liPerServer2: Integer;
begin
try
liPerServer1 := 5;
liPerServer2 := 10;
//INTERNET_OPTION_MAX_CONNS_PER_SERVER 73
InternetSetOption(nil, 73, @liPerServer1, SizeOf(Integer));
//INTERNET_OPTION_MAX_CONNS_PER_1_0_SERVER 74
InternetSetOption(nil, 74, @liPerServer2, SizeOf(Integer));
except
end;
end;
function WW_InternetOpen: Boolean;
var
ltInfo: INTERNET_CONNECTED_INFO;
begin
FNet := InternetOpen(PChar(CONST_AGENT), LProxyType, PChar(FProxy), nil, 0);
Result := (FNet <> nil);
if Result then begin
try
if not FWininetStateChanged then begin
//INTERNET_OPTION_CONNECTED_STATE 50
//取消IE的脱机状态
ltInfo.dwConnectedState := INTERNET_STATE_CONNECTED;
ltInfo.dwFlags := 0; // ISO_FORCE_DISCONNECTED;
InterNetSetOption(FNet, INTERNET_OPTION_CONNECTED_STATE, @ltInfo, SizeOf(ltInfo));
end;
except
end;
//InternetSetStatusCallBack(FNet, @StatusCallBack);
//INTERNET_OPTION_HTTP_DECODING
if InternetSetOption(FNet, 65, @Result, 1) then begin
Beep;
end;
end else begin
AssignError(wwecOpen);
end;
end;
function WW_InternetConnect: Boolean;
var
context: dword;
begin
//同步通讯设置
context := 0;
//异步通讯需要设置特定值
//FCallBackContext.CallbackID := 0;
//context:=dword(@FCallBackContext);
FSession := InternetConnect(FNet, PChar(FServerName),
PortToUse(FServerPort), '', '', INTERNET_SERVICE_HTTP, 0, context);
Result := (FSession <> nil);
if not (Result) then AssignError(wwecConnect);
end;
begin
Result := False;
if FAbort then Exit;
if WW_AttemptConnect then
begin
LProxyType := DetectProxyServer;
SetLastError(0);
if not FWininetStateChanged then CancelMaxConnectLimite();
Result := WW_InternetOpen and WW_InternetConnect;
FWininetStateChanged := True;
end;
end;
function TWnWinetClass.OpenRequest: Boolean;
var
context, ATimeOut, dwFlags: DWORD;
begin
Result := False;
if FAbort then
Exit;
context := 0;
if FSecure then
begin
FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
(GetHttpVersion), nil, nil,
INTERNET_FLAG_KEEP_CONNECTION or INTERNET_FLAG_SECURE or
SECURITY_FLAG_IGNORE_UNKNOWN_CA or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID, context);
ATimeOut := 0;
dwFlags := 0;
if (FRequest <> nil) and (not InternetQueryOption(FRequest,
INTERNET_OPTION_SECURITY_FLAGS, Pointer(@ATimeOut), dwFlags)) then
begin
GetLastError;
end;
end
else
begin
FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
(getHttpVersion), nil, nil, { Ord(FSecure) * INTERNET_FLAG_SECURE or }
INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_RELOAD or
INTERNET_FLAG_KEEP_CONNECTION, context);
end;
Result := (FRequest <> nil);
if not(Result) then
AssignError(wwecOpenRequest);
end;
function TWnWinetClass.PerformMethod: Boolean;
var
ATimeOut, dwFlags: DWORD;
// LErr: Cardinal;
begin
Result := False;
if FAbort then Exit;
if Assigned(FRequestStream) and (FRequestStream.Size > 0) then
Result := HTTPSendRequest(FRequest, nil, 0, FRequestStream.Memory, FRequestStream.Size)
else
Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
// Result := HTTPSendRequest(FRequest, D_C_T, D_C_T_S, nil, 0);
if not(Result) then
begin
if GetLastError = ERROR_INTERNET_INVALID_CA then // WinInet 无效证书颁发机构错误
begin
ATimeOut := 0;
dwFlags := 0;
InternetQueryOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, Pointer
(@ATimeOut), dwFlags);
dwFlags := dwFlags or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
InternetSetOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags,
SizeOf(integer));
Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
end
else
begin
AssignError(wwecExecRequest);
Exit;
end;
end;
Result := ReadResponseHeader
and FixContentLength and FixContentType and ReadResponse;
end;
function TWnWinetClass.PortToUse(APort: Integer): Integer;
begin
if APort > 0 then
Result := APort
else
if FSecure then
Result := INTERNET_DEFAULT_HTTPS_PORT
else
Result := INTERNET_DEFAULT_HTTP_PORT;
end;
function TWnWinetClass.ReadResponse: Boolean;
var
ASize, ARead: DWORD;
ABuffer: Pointer;
begin
Result := False;
if FAbort then Exit;
FResponseStream.Clear;
ASize := BUFFER_SIZE;
FTotal := 0;
ABuffer := AllocMem(ASize);
try
// HookDataReadSized;
repeat
Result := InternetReadFile(FRequest, ABuffer, ASize, ARead);
if not Result then
begin
AssignError(wwecReadFile);
Break;
end;
if (ARead > 0) then
begin
FResponseStream.WriteBuffer(ABuffer^, ARead);
Inc(FTotal, ARead);
//FTotal := ARead;
//HookDataReadSized;
end;
until ((ARead = 0) or FAbort);
FResponseStream.Seek(0,0);
finally
FreeMem(ABuffer, 0);
end;
end;
function TWnWinetClass.ReadResponseHeader: Boolean;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_STATUS_CODE);
if not Result then
begin
AssignError(wwecStatus);
Exit;
end;
FStatus := StrToIntDef(FData, -1);
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_RAW_HEADERS_CRLF);
if Result then
FResponseHeader := FData
else
AssignError(wwecHeader);
end;
procedure TWnWinetClass.SetAbort(const Value: Boolean);
begin
FAbort := Value;
end;
class function TWnWinetClass.StreamToHex(AStream: TMemoryStream): string;
var
I: Integer;
Lb: Byte;
begin
Result := '';
AStream.Seek(0,0);
for I := 1 to AStream.Size do
begin
AStream.ReadBuffer(LB,1);
Result := Result + IntToHex(Ord(Lb),2)+ ' ';
//if (I mod ALen) = 0 then
// Result := Result + #13#10;
end;
end;
end.
interface
uses
Windows,Messages,SysUtils,Classes,WinInet;
const
CONST_AGENT = 'Wininet by Enli';
BUFFER_SIZE = 4096;
type
//定义http的请求调用方式
//TWinWrapVerbs = (wwvGET, wwvPOST, wwvMPOST);
//定义协议版本
TWinHttpVersion = (wwvHttp1,wwvHttp11);
//错误类型，没有错误为wwecNil
TWinInetErrorCauses = (wwecNil, //0
wwecAttemptConnect, //1
wwecOpen, //2
wwecConnect, //3
wwecOpenRequest, //4
wwecConfigureRequest, //5
wwecExecRequest, //6
wwecEndRequest, //7
wwecTimeOut, //8
wwecUPD, //9
wwecAbort, //10
wwecStatus, //11
wwecHeader, //12
wwecContentLength, //13
wwecContentType, //14
wwecReadFile, //15
wwecWriteFile); //16
TProxyInfo = record
FProxyType : Integer; //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
FProxyServer : string;
FProxyPort : Integer;
FProxyUserName : string;
FProxyUserPass : string;
end;
TWnWinetClass = class
private
FNet: HINTERNET;
FRequest: HINTERNET;
FSession: HINTERNET;
FRequestStream: TMemoryStream;
FResponseStream: TMemoryStream;
FVerb: string;
FAbort: Boolean;
FWininetStateChanged: Boolean;
FTimeOut: Integer;
FSecure: Boolean;
FProxyInfo: TProxyInfo;
FServerPort: Integer;
FEncodeUrl: string;
FErrInfo: string;
FServerPass: string;
FServerUser: string;
FServerName: string;
FProxy : string;
FHttpHeader: string;
FData: array [0 .. BUFFER_SIZE] of Char;
FErrorCause: TWinInetErrorCauses;
FHttpVersion: TWinHttpVersion;
FStatus: integer;
FContentType: string;
FContentLength: Int64;
FTotal: Int64;
FResponseHeader: string;
procedure SetAbort(const Value: Boolean);
procedure FixServerInfo;
procedure FixProxyServerInfo;
function OpenConnection: Boolean;
function OpenRequest: Boolean;
function ConfigureRequest: Boolean;
function PerformMethod: Boolean;
function DetectProxyServer: DWORD;
function PortToUse(APort: Integer): Integer;
function FetchHeader(AFlags: integer): Boolean;
function ReadResponse: Boolean; // 读取接受数据
function ReadResponseHeader: Boolean; //获取返回数据包头
function FixContentLength: Boolean; // 获取接受数据的大小
function FixContentType: Boolean; // 获取接受数据的类型
function FixWinINetError(AError: integer): string;
function GetHttpVersion: string;
procedure AssignError(AError: TWinInetErrorCauses);
public
constructor Create;
destructor Destroy; override;
property Abort: Boolean read FAbort write SetAbort;
property Response: TMemoryStream read FResponseStream;
property HttpVersion: TWinHttpVersion read FHttpVersion write FHttpVersion;
property ServerName: string read FServerName write FServerName;
property ServerPort: Integer read FServerPort write FServerPort;
property ServerUser: string read FServerUser write FServerUser;
property ServerPass: string read FServerPass write FServerPass;
property ProxyInfo: TProxyInfo read FProxyInfo write FProxyInfo;
property HttpHeader: string read FHttpHeader write FHttpHeader;
property ResponseHeader: string read FResponseHeader write FResponseHeader;
property Status: Integer read FStatus;
property ContentLength: Int64 read FContentLength;
property Total: Int64 read FTotal;
property ErrInfo: string read FErrInfo;
property ErrorCause: TWinInetErrorCauses read FErrorCause;
procedure CleanUp(isAll: Boolean);
function HttpGet(isUrl:string;iiTimeout:Integer;ASecure:Boolean = False):boolean;
function HttpPost(isUrl:string;AStream:TMemoryStream;iiTimeout:Integer;ASecure:Boolean = False):boolean;
class function StreamToHex(AStream: TMemoryStream): string;
class procedure HexToStream(AStream: TMemoryStream;AHex: string);
end;
implementation
{ TWnWinetClass }
procedure TWnWinetClass.AssignError(AError: TWinInetErrorCauses);
var
I, H: Integer;
LTemp: string;
LR: Cardinal;
begin
FErrorCause := AError;
if Length(FErrInfo) = 0 then
begin
LR := GetLastError;
if (LR < 12000) or (LR < 12175) then
begin
H := GetModuleHandle('wininet.dll');
SetLength(LTemp, 256);
I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), LR, 0,
PChar(LTemp), 256, nil);
SetLength(LTemp, I);
FErrInfo := 'Error '+IntTostr(LR)+':'+LTemp;
end
else
FErrInfo := 'Error '+IntTostr(LR)+':'+SysErrorMessage(GetLastError);
end;
end;
procedure TWnWinetClass.CleanUp(isAll: Boolean);
begin
if isAll then
begin
if Assigned(FRequest) then
begin
InternetCloseHandle(FRequest);
FRequest := nil;
end;
if Assigned(FSession) then
begin
InternetCloseHandle(FSession);
FSession := nil;
end;
if Assigned(FNet) then
begin
InternetCloseHandle(FNet);
FNet := nil;
end;
end;
//FResponse.Clear;
SetLength(FProxy,0);
end;
function TWnWinetClass.ConfigureRequest: Boolean;
function SetUPD(AOption: DWORD; AUPD: PChar): Boolean;
begin
Result := (Length(AUPD) = 0) or InternetSetOption
(FRequest, AOption, AUPD, Length(AUPD));
end;
begin
Result := False;
if FAbort then
Exit;
// 设置HTTP头
{if FFileSize > 0 then
begin
if Length(FHttpHeader) > 0 then
FHttpHeader := FHttpHeader + #13#10'Range: bytes=' + IntTostr(FFileSize)
+ '-'#13#10
else
FHttpHeader := 'Range: bytes=' + IntTostr(FFileSize) + '-'#13#10;
end;}
if Length(FHttpHeader) > 0 then
begin
Result := HttpAddRequestHeaders(FRequest, PWideChar(FHttpHeader), Cardinal
(-1), HTTP_ADDREQ_FLAG_ADD or HTTP_ADDREQ_FLAG_REPLACE);
if not Result then
begin
AssignError(wwecConfigureRequest);
Exit;
end;
end;
// 设置超时
if (FTimeOut < 1) or (FTimeOut > 999) then
FTimeOut := 30;
FTimeOut := FTimeOut * 1000;
Result := InternetSetOption(FNet, INTERNET_OPTION_CONNECT_TIMEOUT, @FTimeOut,
SizeOf(integer)) and InternetSetOption
(FNet, INTERNET_OPTION_RECEIVE_TIMEOUT, @FTimeOut, SizeOf(integer))
and InternetSetOption(FNet, INTERNET_OPTION_SEND_TIMEOUT, @FTimeOut, SizeOf
(integer));
if not(Result) then
begin
AssignError(wwecTimeOut);
Exit;
end;
// 设置代理用户密码，访问用户密码
if SetUPD(INTERNET_OPTION_PROXY_USERNAME, PChar(FProxyInfo.FProxyUserName))
and SetUPD(INTERNET_OPTION_PROXY_PASSWORD, PChar(FProxyInfo.FProxyUserPass)
) and SetUPD(INTERNET_OPTION_USERNAME, PChar(FServerPass)) and SetUPD
(INTERNET_OPTION_PASSWORD, PChar(FServerUser)) then
else
AssignError(wwecUPD);
end;
constructor TWnWinetClass.Create;
begin
inherited;
FResponseStream := TMemoryStream.Create;
FRequest := nil;
FSession := nil;
FRequestStream := nil;
FNet := nil;
FAbort := False;
FSecure := False;
FWininetStateChanged := False;
SetLength(FEncodeUrl,0);
SetLength(FErrInfo,0);
SetLength(FServerUser,0);
SetLength(FServerPass,0);
SetLength(FProxy,0);
FVerb := 'GET';
end;
destructor TWnWinetClass.Destroy;
begin
FResponseStream.Free;
inherited;
end;
function TWnWinetClass.DetectProxyServer: DWORD;
begin
//-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
//Result:
//INTERNET_OPEN_TYPE_PRECONFIG 0
//INTERNET_OPEN_TYPE_DIRECT 1
//INTERNET_OPEN_TYPE_PROXY 3
//INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY 4
with FProxyInfo do
case (FProxyType-1) of
0: Result := INTERNET_OPEN_TYPE_DIRECT;
1:
begin
Result := INTERNET_OPEN_TYPE_PROXY;
FProxy := Format('socks=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
end;
2:
begin
Result := INTERNET_OPEN_TYPE_PROXY;
FProxy := Format('socks5=%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
end;
3:
begin
Result := INTERNET_OPEN_TYPE_PROXY;
FProxy := Format('%s:%s',[FProxyServer,Inttostr(FProxyPort)]);
end;
else
Result := INTERNET_OPEN_TYPE_PRECONFIG;
end;
end;
function TWnWinetClass.FetchHeader(AFlags: integer): Boolean;
var
BufLen, Index: DWORD;
begin
Result := False;
if FAbort then Exit;
Index := 0;
BufLen := BUFFER_SIZE;
FillChar(FData, BufLen, 0);
Result := HttpQueryInfo(FRequest, AFlags, @FData, BufLen, Index);
end;
function TWnWinetClass.FixContentLength: Boolean;
var
LTemp: string;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_CONTENT_LENGTH);
LTemp := FData;
if Result then
FContentLength := StrToInt64Def(LTemp, 0)
else
AssignError(wwecContentLength);
end;
function TWnWinetClass.FixContentType: Boolean;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_CONTENT_TYPE);
if Result then
FContentType := FData
else
AssignError(wwecContentType);
end;
procedure TWnWinetClass.FixProxyServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
ls1ServerName := LowerCase(FServerName);
liLoc := Pos(':', ls1ServerName);
if liLoc = 0 then Exit;
lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
FServerName := PChar(Copy(ls1ServerName, 1, liLoc - 1));
FServerPort := StrToIntDef(lsPort,FServerPort);
end;
procedure TWnWinetClass.FixServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
if FProxyInfo.FProxyType = 0 then Exit;
ls1ServerName := LowerCase(FProxyInfo.FProxyServer);
liLoc := Pos(':', ls1ServerName);
if liLoc = 0 then Exit;
lsPort := Copy(ls1ServerName, liLoc + 1, Length(ls1ServerName) - liLoc);
FProxyInfo.FProxyServer := PChar(Copy(ls1ServerName, 1, liLoc - 1));
FProxyInfo.FProxyPort := StrToIntDef(lsPort,FProxyInfo.FProxyPort);
end;
function TWnWinetClass.FixWinINetError(AError: integer): string;
begin
//Result := 'Http Status: ' + IntTostr(AError);
if FetchHeader(HTTP_QUERY_STATUS_TEXT) then
Result := FData
//if not Result then
else
begin
AssignError(wwecStatus);
Exit;
end;
end;
function TWnWinetClass.GetHttpVersion: string;
begin
if FHttpVersion = wwvHttp1 then
Result := 'HTTP/1.0'
else
Result := 'HTTP/1.1';
end;
class procedure TWnWinetClass.HexToStream(AStream: TMemoryStream;AHex: string);
var
I,iLen: Integer;
LTemp: string;
LB : Byte;
begin
iLen := Length(AHex);
if (iLen mod 3) <> 0 then
begin
Assert(False,'hex字符串错误');
Exit;
end;
for I := 0 to (iLen div 3) - 1 do
begin
LTemp := Copy(AHex,I*3+1,2);
LB := StrToIntDef('$'+LTemp,0);
AStream.WriteBuffer(Lb,1);
//Assert(Pos(IntToStr(LB),LTemp)=0,'asdf');
end;
end;
function TWnWinetClass.HttpGet(isUrl: string; iiTimeout: integer;
ASecure: Boolean): boolean;
begin
FVerb := 'GET';
FRequest := nil;
FRequestStream := nil;
SetLastError(0);
FErrInfo := '';
FErrorCause := wwecNil;
Result := False;
FEncodeUrl := isUrl;
FTimeOut := iiTimeout;
FSecure := ASecure;
FixServerInfo;
FixProxyServerInfo;
Result := OpenConnection
and OpenRequest
and ConfigureRequest
and PerformMethod;
CleanUp(True);
end;
function TWnWinetClass.HttpPost(isUrl: string; AStream: TMemoryStream;
iiTimeout: Integer; ASecure: Boolean): boolean;
begin
FVerb := 'POST';
FRequestStream := AStream;
SetLastError(0);
FErrInfo := '';
FErrorCause := wwecNil;
Result := False;
FEncodeUrl := isUrl;
FTimeOut := iiTimeout;
FSecure := ASecure;
FixServerInfo;
FixProxyServerInfo;
Result := OpenConnection
and OpenRequest
and ConfigureRequest
and PerformMethod;
CleanUp(True);
end;
function TWnWinetClass.OpenConnection: Boolean;
var
LProxyType: DWORD;
function WW_AttemptConnect: Boolean;
begin
Result := (CompareText(FServerName, 'localhost') = 0) or
(InternetAttemptConnect(0) = ERROR_SUCCESS);
if not (Result) then AssignError(wwecAttemptConnect);
end;
procedure CancelMaxConnectLimite();
var
liPerServer1, liPerServer2: Integer;
begin
try
liPerServer1 := 5;
liPerServer2 := 10;
//INTERNET_OPTION_MAX_CONNS_PER_SERVER 73
InternetSetOption(nil, 73, @liPerServer1, SizeOf(Integer));
//INTERNET_OPTION_MAX_CONNS_PER_1_0_SERVER 74
InternetSetOption(nil, 74, @liPerServer2, SizeOf(Integer));
except
end;
end;
function WW_InternetOpen: Boolean;
var
ltInfo: INTERNET_CONNECTED_INFO;
begin
FNet := InternetOpen(PChar(CONST_AGENT), LProxyType, PChar(FProxy), nil, 0);
Result := (FNet <> nil);
if Result then begin
try
if not FWininetStateChanged then begin
//INTERNET_OPTION_CONNECTED_STATE 50
//取消IE的脱机状态
ltInfo.dwConnectedState := INTERNET_STATE_CONNECTED;
ltInfo.dwFlags := 0; // ISO_FORCE_DISCONNECTED;
InterNetSetOption(FNet, INTERNET_OPTION_CONNECTED_STATE, @ltInfo, SizeOf(ltInfo));
end;
except
end;
//InternetSetStatusCallBack(FNet, @StatusCallBack);
//INTERNET_OPTION_HTTP_DECODING
if InternetSetOption(FNet, 65, @Result, 1) then begin
Beep;
end;
end else begin
AssignError(wwecOpen);
end;
end;
function WW_InternetConnect: Boolean;
var
context: dword;
begin
//同步通讯设置
context := 0;
//异步通讯需要设置特定值
//FCallBackContext.CallbackID := 0;
//context:=dword(@FCallBackContext);
FSession := InternetConnect(FNet, PChar(FServerName),
PortToUse(FServerPort), '', '', INTERNET_SERVICE_HTTP, 0, context);
Result := (FSession <> nil);
if not (Result) then AssignError(wwecConnect);
end;
begin
Result := False;
if FAbort then Exit;
if WW_AttemptConnect then
begin
LProxyType := DetectProxyServer;
SetLastError(0);
if not FWininetStateChanged then CancelMaxConnectLimite();
Result := WW_InternetOpen and WW_InternetConnect;
FWininetStateChanged := True;
end;
end;
function TWnWinetClass.OpenRequest: Boolean;
var
context, ATimeOut, dwFlags: DWORD;
begin
Result := False;
if FAbort then
Exit;
context := 0;
if FSecure then
begin
FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
(GetHttpVersion), nil, nil,
INTERNET_FLAG_KEEP_CONNECTION or INTERNET_FLAG_SECURE or
SECURITY_FLAG_IGNORE_UNKNOWN_CA or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID, context);
ATimeOut := 0;
dwFlags := 0;
if (FRequest <> nil) and (not InternetQueryOption(FRequest,
INTERNET_OPTION_SECURITY_FLAGS, Pointer(@ATimeOut), dwFlags)) then
begin
GetLastError;
end;
end
else
begin
FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
(getHttpVersion), nil, nil, { Ord(FSecure) * INTERNET_FLAG_SECURE or }
INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_RELOAD or
INTERNET_FLAG_KEEP_CONNECTION, context);
end;
Result := (FRequest <> nil);
if not(Result) then
AssignError(wwecOpenRequest);
end;
function TWnWinetClass.PerformMethod: Boolean;
var
ATimeOut, dwFlags: DWORD;
// LErr: Cardinal;
begin
Result := False;
if FAbort then Exit;
if Assigned(FRequestStream) and (FRequestStream.Size > 0) then
Result := HTTPSendRequest(FRequest, nil, 0, FRequestStream.Memory, FRequestStream.Size)
else
Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
// Result := HTTPSendRequest(FRequest, D_C_T, D_C_T_S, nil, 0);
if not(Result) then
begin
if GetLastError = ERROR_INTERNET_INVALID_CA then // WinInet 无效证书颁发机构错误
begin
ATimeOut := 0;
dwFlags := 0;
InternetQueryOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, Pointer
(@ATimeOut), dwFlags);
dwFlags := dwFlags or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
InternetSetOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags,
SizeOf(integer));
Result := HTTPSendRequest(FRequest, nil, 0, nil, 0);
end
else
begin
AssignError(wwecExecRequest);
Exit;
end;
end;
Result := ReadResponseHeader
and FixContentLength and FixContentType and ReadResponse;
end;
function TWnWinetClass.PortToUse(APort: Integer): Integer;
begin
if APort > 0 then
Result := APort
else
if FSecure then
Result := INTERNET_DEFAULT_HTTPS_PORT
else
Result := INTERNET_DEFAULT_HTTP_PORT;
end;
function TWnWinetClass.ReadResponse: Boolean;
var
ASize, ARead: DWORD;
ABuffer: Pointer;
begin
Result := False;
if FAbort then Exit;
FResponseStream.Clear;
ASize := BUFFER_SIZE;
FTotal := 0;
ABuffer := AllocMem(ASize);
try
// HookDataReadSized;
repeat
Result := InternetReadFile(FRequest, ABuffer, ASize, ARead);
if not Result then
begin
AssignError(wwecReadFile);
Break;
end;
if (ARead > 0) then
begin
FResponseStream.WriteBuffer(ABuffer^, ARead);
Inc(FTotal, ARead);
//FTotal := ARead;
//HookDataReadSized;
end;
until ((ARead = 0) or FAbort);
FResponseStream.Seek(0,0);
finally
FreeMem(ABuffer, 0);
end;
end;
function TWnWinetClass.ReadResponseHeader: Boolean;
begin
Result := False;
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_STATUS_CODE);
if not Result then
begin
AssignError(wwecStatus);
Exit;
end;
FStatus := StrToIntDef(FData, -1);
if FAbort then Exit;
Result := FetchHeader(HTTP_QUERY_RAW_HEADERS_CRLF);
if Result then
FResponseHeader := FData
else
AssignError(wwecHeader);
end;
procedure TWnWinetClass.SetAbort(const Value: Boolean);
begin
FAbort := Value;
end;
class function TWnWinetClass.StreamToHex(AStream: TMemoryStream): string;
var
I: Integer;
Lb: Byte;
begin
Result := '';
AStream.Seek(0,0);
for I := 1 to AStream.Size do
begin
AStream.ReadBuffer(LB,1);
Result := Result + IntToHex(Ord(Lb),2)+ ' ';
//if (I mod ALen) = 0 then
// Result := Result + #13#10;
end;
end;
end.
