// < TAsyncInet >
uses WinInet, StrUtils;
type
TAsyncInet =
class;
PINET_CONTEXT = ^INET_CONTEXT;
INET_CONTEXT =
record
Obj: TAsyncInet;
Context: DWORD;
end;
TRequestType = (
_GET,
_POST
);
TAsyncInet =
class
const
CONTEXT_CONNECT = 0;
CONTEXT_REQUESTHANDLE = 1;
private
FhConnectEvent: THandle;
FhRequestOpenEvent: THandle;
FhRequestCompleteEvent: THandle;
FhOpen: HINTERNET;
FhConnect: HINTERNET;
FhRequest: HINTERNET;
FContext: INET_CONTEXT;
protected
public
constructor Create;
reintroduce;
destructor Destroy;
override;
function Connect(UserAgent, Host:
string; Timeout: DWORD = 20000): Boolean;
function SendRequest(RequestType: TRequestType;
Url, RequestData,
Referrer:
string; Timeout: DWORD = 20000): Boolean;
function ReadData(Buffer: Pointer; Size: DWORD; Timeout: DWORD = 20000): DWORD;
procedure Disconnect;
end;
constructor TAsyncInet.Create;
begin
inherited;
FhConnectEvent := CreateEvent(
nil, false, false,
nil);
FhRequestOpenEvent := CreateEvent(
nil, false, false,
nil);
FhRequestCompleteEvent := CreateEvent(
nil, false, false,
nil);
FhOpen :=
nil;
FhConnect :=
nil;
FhRequest :=
nil;
FContext.Obj :=
nil;
FContext.Context := 0;
end;
destructor TAsyncInet.Destroy;
begin
if FhConnectEvent > 0
then
CloseHandle(FhConnectEvent);
if FhRequestOpenEvent > 0
then
CloseHandle(FhRequestOpenEvent);
if FhRequestCompleteEvent > 0
then
CloseHandle(FhRequestCompleteEvent);
Disconnect;
inherited;
end;
procedure StatusCallback(hInet: HINTERNET; dwContext: DWORD_PTR;
dwInternetStatus: DWORD; lpvStatusInformation: Pointer;
dwStatusInformationLength: DWORD);
stdcall;
var
pContext: PINET_CONTEXT;
pConnectResult, pRequestResult: PINTERNET_ASYNC_RESULT;
begin
pContext := PINET_CONTEXT(dwContext);
case pContext^.Context
of
TAsyncInet.CONTEXT_CONNECT:
begin
if dwInternetStatus = INTERNET_STATUS_HANDLE_CREATED
then
begin
pConnectResult := PINTERNET_ASYNC_RESULT(lpvStatusInformation);
pContext^.Obj.FhConnect := HINTERNET(pConnectResult^.dwResult);
SetEvent(pContext^.Obj.FhConnectEvent);
end;
end;
TAsyncInet.CONTEXT_REQUESTHANDLE:
begin
case dwInternetStatus
of
INTERNET_STATUS_HANDLE_CREATED:
begin
pRequestResult := PINTERNET_ASYNC_RESULT(lpvStatusInformation);
pContext^.Obj.FhRequest := HINTERNET(pRequestResult^.dwResult);
SetEvent(pContext^.Obj.FhRequestOpenEvent);
end;
INTERNET_STATUS_REQUEST_COMPLETE:
begin
SetEvent(pContext^.Obj.FhRequestCompleteEvent);
end;
end;
end;
end;
end;
function TAsyncInet.Connect(UserAgent, Host:
string; Timeout: DWORD): Boolean;
begin
result := false;
Disconnect;
ResetEvent(FhConnectEvent);
ResetEvent(FhRequestOpenEvent);
ResetEvent(FhRequestCompleteEvent);
FhOpen := InternetOpen(PChar(UserAgent),
INTERNET_OPEN_TYPE_PRECONFIG,
nil,
nil,
INTERNET_FLAG_ASYNC);
if FhOpen =
nil then
exit;
if Boolean(InternetSetStatusCallback(FhOpen, INTERNET_STATUS_CALLBACK(@StatusCallback)))
then
exit;
FContext.Context := TAsyncInet.CONTEXT_CONNECT;
FContext.Obj := self;
FhConnect := InternetConnect(FhOpen,
PChar(Host),
INTERNET_DEFAULT_PORT,
nil,
nil,
INTERNET_SERVICE_HTTP,
INTERNET_FLAG_KEEP_CONNECTION
or INTERNET_FLAG_DONT_CACHE,
DWORD(@FContext));
if FhConnect =
nil then
begin
if GetLastError = ERROR_IO_PENDING
then
begin
if Boolean(WaitForSingleObject(FhConnectEvent, Timeout))
then
exit;
end;
exit;
end;
if FhConnect =
nil then
exit;
result := true;
end;
function TAsyncInet.SendRequest(RequestType: TRequestType;
Url:
string;
RequestData, Referrer:
string; Timeout: DWORD): Boolean;
var
verb:
string;
requested: Boolean;
header:
string;
begin
result := false;
requested := false;
FContext.Context := TAsyncInet.CONTEXT_REQUESTHANDLE;
FContext.Obj := self;
if RequestType = _GET
then
verb := '
GET'
else if RequestType = _POST
then
verb := '
POST';
FhRequest := HttpOpenRequest(FhConnect,
PChar(verb),
PChar(
Url),
nil,
PChar(Referrer),
nil,
INTERNET_FLAG_RELOAD
or
INTERNET_FLAG_KEEP_CONNECTION
or
INTERNET_FLAG_DONT_CACHE,
DWORD(@FContext));
if FhRequest =
nil then
begin
if GetLastError = ERROR_IO_PENDING
then
begin
if Boolean(WaitForSingleObject(FhRequestOpenEvent, Timeout))
then
exit;
end;
end;
if FhRequest =
nil then
exit;
if RequestType = _GET
then
requested := HttpSendRequest(FhRequest,
nil,
0,
PChar(RequestData),
Length(RequestData))
else if RequestType = _POST
then
begin
header := '
Content-Type: application/x-www-form-urlencoded';
requested := HttpSendRequest(FhRequest,
PChar(header),
Length(header),
PChar(RequestData),
Length(RequestData));
end;
if not requested
then
begin
if GetLastError = ERROR_IO_PENDING
then
begin
if WaitForSingleObject(FhRequestCompleteEvent, Timeout) = WAIT_TIMEOUT
then
begin
Disconnect;
exit;
end;
end;
end;
result := true;
end;
function TAsyncInet.ReadData(Buffer: Pointer; Size: DWORD; Timeout: DWORD): DWORD;
var
inetBuffers: INTERNET_BUFFERS;
begin
result := 0;
ZeroMemory(@inetBuffers, SizeOf(INTERNET_BUFFERS));
inetBuffers.dwStructSize := SizeOf(INTERNET_BUFFERS);
inetBuffers.lpvBuffer := Buffer;
inetBuffers.dwBufferLength := Size - 1;
FContext.Context := TAsyncInet.CONTEXT_REQUESTHANDLE;
FContext.Obj := self;
if not InternetReadFileEx(FhRequest, inetBuffers, 0, DWORD(@FContext))
then
begin
if GetLastError = ERROR_IO_PENDING
then
begin
if WaitForSingleObject(FhRequestCompleteEvent, Timeout) = WAIT_TIMEOUT
then
exit;
end;
end;
result := inetBuffers.dwBufferLength;
end;
procedure TAsyncInet.Disconnect;
begin
InternetCloseHandle(FhOpen);
InternetCloseHandle(FhConnect);
InternetCloseHandle(FhRequest);
FhOpen :=
nil;
FhConnect :=
nil;
FhRequest :=
nil;
end;
// < /TAsyncInet >
procedure ExtractUrlTo(
const Url:
string;
var Host, Path:
string);
var
posLeft, posRight: Integer;
begin
posLeft := Pos('
//www.',
Url) + 6;
if posLeft = 6
then
begin
posLeft := Pos('
//',
Url) + 2;
if posLeft = 2
then
begin
posLeft := Pos('
www.',
Url) + 4;
if posLeft = 4
then
posLeft := 1;
end;
end;
posRight := StrUtils.PosEx('
/',
Url, posLeft);
if posRight > 0
then
Path := Copy(
Url, posRight, Length(
Url) - posRight + 1)
else begin
posRight := Length(
Url) + 1;
Path := '
/';
end;
Host := Copy(
Url, posLeft, posRight - posLeft);
end;
function DownloadAsync(
const Url, FileName): Boolean;
const
BUFFER_SIZE = 1024 * 4;
var
inet: TAsyncInet;
host, path:
string;
buff:
array[0..BUFFER_SIZE - 1]
of Byte;
currentBytes: DWORD;
f:
File;
begin
result := false;
inet := TAsyncInet.Create;
try
ZeroMemory(@buff[0], BUFFER_SIZE);
ExtractUrlTo(
Url, host, path);
if inet.Connect('
Test', host)
then
if inet.SendRequest(_GET, path, '
', '
')
then
begin
AssignFile(f, FileName);
Rewrite(f, 1);
repeat
currentBytes := inet.ReadData(@buff, BUFFER_SIZE);
buff[currentBytes] := 0;
BlockWrite(f, buff, currentBytes);
until currentBytes = 0;
CloseFile(f);
result := true;
end;
finally
inet.Free;
end;
end;
// Call
var
url, filename:
string;
begin
url := '
http://212.183.159.230/50MB.zip';
filename := '
example.zip';
DownloadAsync(
url, filename);
ShowMessage('
Finished!');
end;