unit uWnDownClass;
interface
uses
Windows,Messages,SysUtils,Classes,WinInet;
const
WM_HTTPCOMM_PROGRESS = WM_USER + 1700;
InnerAgent = 'Mozilla/4.0 (compatible; MSIE 6.0; Win32)';
HttpVersion = 'HTTP/1.1';
D_C_T = 'Content-Type:application/x-www-form-urlencoded';
D_C_T_S = Length(D_C_T);
BUFFER_SIZE = 4096;
type
//错误类型，没有错误为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
wwecContentLength, //12
wwecContentType, //13
wwecReadFile, //14
wwecWriteFile); //15
TProxyInfo = record
public
FProxyType : integer; //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
FProxyServer : String;
FProxyPort : integer;
FProxyUserName : String;
FProxyUserPass : String;
end;
TOnDownloadProgress = procedure(const ASize,ATotal: Int64) of object;
TWnDownClass = class
private
FAbort: Boolean;
//FhNotify: HWND;
FResponse: TMemoryStream;
//FKeepConnected: Boolean;
FNet: HINTERNET;
FRequest: HINTERNET;
FSession: HINTERNET;
FProxyInfo: TProxyInfo;
FProxy: string;
FServerPort: integer;
FServerName: string;
FEncodeUrl: string;
FVerb: string;
FHttpHeader: string;
//FpUserData: Pointer;
FSecure: Boolean;
FTimeOut: Integer;
FErrorCause: TWinInetErrorCauses;
FWininetStateChanged: Boolean;
FErrInfo: string;
FServerPass: string;
FServerUser: string;
FData: array[0..BUFFER_SIZE] of Char;
FStatus: Integer;
FContentType: string;
FContentLength: Int64;
FTotal: Int64;
FFileSize: Int64;
FOnDownloadProgress: TOnDownloadProgress;
procedure SetAbort(const Value: Boolean);
procedure FixServerInfo;
procedure FixProxyServerInfo;
function OpenConnection: Boolean;
function OpenRequest: Boolean;
function ConfigureRequest: Boolean;
function PerformGet: Boolean;
procedure AssignError(AError: TWinInetErrorCauses);
function DetectProxyServer: DWORD;
function PortToUse(APort: Integer): Integer;
function FetchHeader(AFlags: Integer): Boolean;
function FixContentLength: Boolean; //获取接受数据的大小
function FixContentType: Boolean; //获取接受数据的类型
function ReadResponse: Boolean; //读取接受数据
function FixWinINetError(AError: Integer): string;
procedure HookDataReadSized;
procedure SetOnDownloadProgress(const Value: TOnDownloadProgress);
public
constructor Create;
destructor Destroy;override;
property Abort: Boolean read FAbort write SetAbort;
//property hNotify:HWND read FhNotify write FhNotify;
property Response: TMemoryStream read FResponse;
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 Status: Integer read FStatus;
property ContentLength: Int64 read FContentLength;
property ContentType: string read FContentType;
property FileSize: Int64 read FFileSize write FFileSize;
property ErrInfo: string read FErrInfo;
property ErrorCause: TWinInetErrorCauses read FErrorCause;
property OnDownloadProgress: TOnDownloadProgress read FOnDownloadProgress write SetOnDownloadProgress;
procedure CleanUp(isAll: Boolean);
function HttpGet(isUrl:string;iiTimeout:integer;ASecure:Boolean = False):boolean;
end;
implementation
uses
HTTPApp;
//HTTP通讯过程中的状态回调函数
procedure StatusCallback(ASession: hInternet; AContext, AIS: DWord; AInfo:
Pointer; ASIN: DWord); stdcall;
//var
// AReason: TWinInetCallBackReason;
// lpHostContext: PInternetCallbackContext;
begin
{ TODO : 回调函数 }
{case AIS of
INTERNET_STATUS_RESOLVING_NAME: AReason := wwcbrResolving;
INTERNET_STATUS_NAME_RESOLVED: AReason := wwcbrResolved;
INTERNET_STATUS_CONNECTING_TO_SERVER: AReason := wwcbrConnecting;
INTERNET_STATUS_CONNECTED_TO_SERVER: AReason := wwcbrConnected;
INTERNET_STATUS_SENDING_REQUEST: AReason := wwcbrWriting;
INTERNET_STATUS_REQUEST_SENT: AReason := wwcbrWritten;
INTERNET_STATUS_RECEIVING_RESPONSE: AReason := wwcbrReading;
INTERNET_STATUS_RESPONSE_RECEIVED: AReason := wwcbrRead;
INTERNET_STATUS_CLOSING_CONNECTION: AReason := wwcbrClosing;
INTERNET_STATUS_CONNECTION_CLOSED: AReason := wwcbrClosed;
else Exit;
end;
lpHostContext := PInternetCallbackContext(AContext);
if Assigned(lpHostContext^.OnSelfCallBack) then begin
lpHostContext^.OnSelfCallBack(AReason);
end;
if Assigned(lpHostContext^.OnCallBack) then begin
lpHostContext^.OnCallBack(AReason);
end; }
end;
{ TWnDownClass }
procedure TWnDownClass.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 TWnDownClass.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 TWnDownClass.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 > 30) 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 TWnDownClass.Create;
begin
inherited;
FResponse := TMemoryStream.Create;
FRequest := nil;
FSession := nil;
FNet := nil;
//FKeepConnected := False;
FAbort := False;
FWininetStateChanged := False;
FErrInfo := '';
FEncodeUrl := '';
FServerUser := '';
FServerPass := '';
FVerb := 'GET';
FStatus := -1;
FFileSize := 0;
SetLength(FProxy,0);
end;
destructor TWnDownClass.Destroy;
begin
FResponse.Free;
inherited;
end;
function TWnDownClass.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 TWnDownClass.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 TWnDownClass.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 TWnDownClass.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 TWnDownClass.FixProxyServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
try
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);
except
end;
end;
procedure TWnDownClass.FixServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
try
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);
except
end;
end;
function TWnDownClass.FixWinINetError(AError: Integer): string;
{var
I, H: Integer;
begin
H := GetModuleHandle('wininet.dll');
SetLength(Result, 256);
I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), AError, 0,
PChar(Result), 256, nil);
SetLength(Result, I);
end; }
begin
Result := 'Http Status: '+ IntToStr(AError);
end;
procedure TWnDownClass.HookDataReadSized;
//var
//nTransPercent: Integer;
begin
//if IsWindow(hNotify) then
//begin
if Assigned(FOnDownloadProgress) then
FOnDownloadProgress(FTotal + FFileSize,FContentLength + FFileSize);
// PostMessage(hNotify, WM_HTTPCOMM_PROGRESS, Integer(pUserData),
// nTransPercent);
//end;
end;
function TWnDownClass.HttpGet(isUrl: string; iiTimeout: integer; ASecure: Boolean): boolean;
begin
SetLastError(0);
FErrInfo := '';
FErrorCause := wwecNil;
Result := False;
FSecure := ASecure;
FTimeOut := iiTimeout;
FTotal := 0;
{ TODO : 不知道是否需要UTF8编码 }
//FEncodeUrl := isUrl; //EncodeUrlUtf8(FEncodeUrl);
FEncodeUrl := HttpEncode(UTF8Encode(isUrl));
FVerb := 'GET';
FixServerInfo;
FixProxyServerInfo;
Result := OpenConnection
and OpenRequest
and ConfigureRequest
and PerformGet;
CleanUp(True);
end;
function TWnDownClass.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(InnerAgent), 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 TWnDownClass.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(HttpVersion), 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(HttpVersion), 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 TWnDownClass.PerformGet: Boolean;
var
AtimeOut, dwFlags: DWORD;
//LErr: Cardinal;
begin
Result := False;
if FAbort then Exit;
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 := FetchHeader(HTTP_QUERY_STATUS_CODE);
if not Result then
begin
AssignError(wwecStatus);
Exit;
end;
FStatus := StrToIntDef(FData, -1);
if (FStatus = HTTP_STATUS_OK) or (FStatus = HTTP_STATUS_PARTIAL_CONTENT) then
begin
Result := FixContentLength and FixContentType and ReadResponse;
end
else
begin
FErrInfo := FixWinINetError(FStatus);
AssignError(wwecStatus);
end;
end;
function TWnDownClass.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 TWnDownClass.ReadResponse: Boolean;
var
ASize, ARead: DWORD;
ABuffer: Pointer;
begin
Result := False;
if FAbort then Exit;
FResponse.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
FResponse.WriteBuffer(ABuffer^, ARead);
Inc(FTotal, ARead);
HookDataReadSized;
end;
until ((ARead = 0) or FAbort);
finally
FreeMem(ABuffer, 0);
end;
end;
procedure TWnDownClass.SetAbort(const Value: Boolean);
begin
FAbort := Value;
if FAbort then
begin
FErrorCause := wwecAbort;
FErrInfo := 'User Download Abouted';
end;
end;
procedure TWnDownClass.SetOnDownloadProgress(const Value: TOnDownloadProgress);
begin
FOnDownloadProgress := Value;
end;
end.
interface
uses
Windows,Messages,SysUtils,Classes,WinInet;
const
WM_HTTPCOMM_PROGRESS = WM_USER + 1700;
InnerAgent = 'Mozilla/4.0 (compatible; MSIE 6.0; Win32)';
HttpVersion = 'HTTP/1.1';
D_C_T = 'Content-Type:application/x-www-form-urlencoded';
D_C_T_S = Length(D_C_T);
BUFFER_SIZE = 4096;
type
//错误类型，没有错误为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
wwecContentLength, //12
wwecContentType, //13
wwecReadFile, //14
wwecWriteFile); //15
TProxyInfo = record
public
FProxyType : integer; //-1: preConfig 0: noproxy 1: sock4 2: sock5 3: http
FProxyServer : String;
FProxyPort : integer;
FProxyUserName : String;
FProxyUserPass : String;
end;
TOnDownloadProgress = procedure(const ASize,ATotal: Int64) of object;
TWnDownClass = class
private
FAbort: Boolean;
//FhNotify: HWND;
FResponse: TMemoryStream;
//FKeepConnected: Boolean;
FNet: HINTERNET;
FRequest: HINTERNET;
FSession: HINTERNET;
FProxyInfo: TProxyInfo;
FProxy: string;
FServerPort: integer;
FServerName: string;
FEncodeUrl: string;
FVerb: string;
FHttpHeader: string;
//FpUserData: Pointer;
FSecure: Boolean;
FTimeOut: Integer;
FErrorCause: TWinInetErrorCauses;
FWininetStateChanged: Boolean;
FErrInfo: string;
FServerPass: string;
FServerUser: string;
FData: array[0..BUFFER_SIZE] of Char;
FStatus: Integer;
FContentType: string;
FContentLength: Int64;
FTotal: Int64;
FFileSize: Int64;
FOnDownloadProgress: TOnDownloadProgress;
procedure SetAbort(const Value: Boolean);
procedure FixServerInfo;
procedure FixProxyServerInfo;
function OpenConnection: Boolean;
function OpenRequest: Boolean;
function ConfigureRequest: Boolean;
function PerformGet: Boolean;
procedure AssignError(AError: TWinInetErrorCauses);
function DetectProxyServer: DWORD;
function PortToUse(APort: Integer): Integer;
function FetchHeader(AFlags: Integer): Boolean;
function FixContentLength: Boolean; //获取接受数据的大小
function FixContentType: Boolean; //获取接受数据的类型
function ReadResponse: Boolean; //读取接受数据
function FixWinINetError(AError: Integer): string;
procedure HookDataReadSized;
procedure SetOnDownloadProgress(const Value: TOnDownloadProgress);
public
constructor Create;
destructor Destroy;override;
property Abort: Boolean read FAbort write SetAbort;
//property hNotify:HWND read FhNotify write FhNotify;
property Response: TMemoryStream read FResponse;
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 Status: Integer read FStatus;
property ContentLength: Int64 read FContentLength;
property ContentType: string read FContentType;
property FileSize: Int64 read FFileSize write FFileSize;
property ErrInfo: string read FErrInfo;
property ErrorCause: TWinInetErrorCauses read FErrorCause;
property OnDownloadProgress: TOnDownloadProgress read FOnDownloadProgress write SetOnDownloadProgress;
procedure CleanUp(isAll: Boolean);
function HttpGet(isUrl:string;iiTimeout:integer;ASecure:Boolean = False):boolean;
end;
implementation
uses
HTTPApp;
//HTTP通讯过程中的状态回调函数
procedure StatusCallback(ASession: hInternet; AContext, AIS: DWord; AInfo:
Pointer; ASIN: DWord); stdcall;
//var
// AReason: TWinInetCallBackReason;
// lpHostContext: PInternetCallbackContext;
begin
{ TODO : 回调函数 }
{case AIS of
INTERNET_STATUS_RESOLVING_NAME: AReason := wwcbrResolving;
INTERNET_STATUS_NAME_RESOLVED: AReason := wwcbrResolved;
INTERNET_STATUS_CONNECTING_TO_SERVER: AReason := wwcbrConnecting;
INTERNET_STATUS_CONNECTED_TO_SERVER: AReason := wwcbrConnected;
INTERNET_STATUS_SENDING_REQUEST: AReason := wwcbrWriting;
INTERNET_STATUS_REQUEST_SENT: AReason := wwcbrWritten;
INTERNET_STATUS_RECEIVING_RESPONSE: AReason := wwcbrReading;
INTERNET_STATUS_RESPONSE_RECEIVED: AReason := wwcbrRead;
INTERNET_STATUS_CLOSING_CONNECTION: AReason := wwcbrClosing;
INTERNET_STATUS_CONNECTION_CLOSED: AReason := wwcbrClosed;
else Exit;
end;
lpHostContext := PInternetCallbackContext(AContext);
if Assigned(lpHostContext^.OnSelfCallBack) then begin
lpHostContext^.OnSelfCallBack(AReason);
end;
if Assigned(lpHostContext^.OnCallBack) then begin
lpHostContext^.OnCallBack(AReason);
end; }
end;
{ TWnDownClass }
procedure TWnDownClass.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 TWnDownClass.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 TWnDownClass.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 > 30) 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 TWnDownClass.Create;
begin
inherited;
FResponse := TMemoryStream.Create;
FRequest := nil;
FSession := nil;
FNet := nil;
//FKeepConnected := False;
FAbort := False;
FWininetStateChanged := False;
FErrInfo := '';
FEncodeUrl := '';
FServerUser := '';
FServerPass := '';
FVerb := 'GET';
FStatus := -1;
FFileSize := 0;
SetLength(FProxy,0);
end;
destructor TWnDownClass.Destroy;
begin
FResponse.Free;
inherited;
end;
function TWnDownClass.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 TWnDownClass.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 TWnDownClass.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 TWnDownClass.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 TWnDownClass.FixProxyServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
try
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);
except
end;
end;
procedure TWnDownClass.FixServerInfo;
var
ls1ServerName, lsPort: string;
liLoc: Integer;
begin
try
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);
except
end;
end;
function TWnDownClass.FixWinINetError(AError: Integer): string;
{var
I, H: Integer;
begin
H := GetModuleHandle('wininet.dll');
SetLength(Result, 256);
I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), AError, 0,
PChar(Result), 256, nil);
SetLength(Result, I);
end; }
begin
Result := 'Http Status: '+ IntToStr(AError);
end;
procedure TWnDownClass.HookDataReadSized;
//var
//nTransPercent: Integer;
begin
//if IsWindow(hNotify) then
//begin
if Assigned(FOnDownloadProgress) then
FOnDownloadProgress(FTotal + FFileSize,FContentLength + FFileSize);
// PostMessage(hNotify, WM_HTTPCOMM_PROGRESS, Integer(pUserData),
// nTransPercent);
//end;
end;
function TWnDownClass.HttpGet(isUrl: string; iiTimeout: integer; ASecure: Boolean): boolean;
begin
SetLastError(0);
FErrInfo := '';
FErrorCause := wwecNil;
Result := False;
FSecure := ASecure;
FTimeOut := iiTimeout;
FTotal := 0;
{ TODO : 不知道是否需要UTF8编码 }
//FEncodeUrl := isUrl; //EncodeUrlUtf8(FEncodeUrl);
FEncodeUrl := HttpEncode(UTF8Encode(isUrl));
FVerb := 'GET';
FixServerInfo;
FixProxyServerInfo;
Result := OpenConnection
and OpenRequest
and ConfigureRequest
and PerformGet;
CleanUp(True);
end;
function TWnDownClass.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(InnerAgent), 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 TWnDownClass.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(HttpVersion), 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(HttpVersion), 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 TWnDownClass.PerformGet: Boolean;
var
AtimeOut, dwFlags: DWORD;
//LErr: Cardinal;
begin
Result := False;
if FAbort then Exit;
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 := FetchHeader(HTTP_QUERY_STATUS_CODE);
if not Result then
begin
AssignError(wwecStatus);
Exit;
end;
FStatus := StrToIntDef(FData, -1);
if (FStatus = HTTP_STATUS_OK) or (FStatus = HTTP_STATUS_PARTIAL_CONTENT) then
begin
Result := FixContentLength and FixContentType and ReadResponse;
end
else
begin
FErrInfo := FixWinINetError(FStatus);
AssignError(wwecStatus);
end;
end;
function TWnDownClass.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 TWnDownClass.ReadResponse: Boolean;
var
ASize, ARead: DWORD;
ABuffer: Pointer;
begin
Result := False;
if FAbort then Exit;
FResponse.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
FResponse.WriteBuffer(ABuffer^, ARead);
Inc(FTotal, ARead);
HookDataReadSized;
end;
until ((ARead = 0) or FAbort);
finally
FreeMem(ABuffer, 0);
end;
end;
procedure TWnDownClass.SetAbort(const Value: Boolean);
begin
FAbort := Value;
if FAbort then
begin
FErrorCause := wwecAbort;
FErrInfo := 'User Download Abouted';
end;
end;
procedure TWnDownClass.SetOnDownloadProgress(const Value: TOnDownloadProgress);
begin
FOnDownloadProgress := Value;
end;
end.