unit System.Net.Downloader;
interface
uses System.SysUtils, System.SyncObjs, System.Net.HttpClient, System.Classes,
System.Generics.Collections, System.Zip;
const
MAX_DOWNLOADS = 5;
type
TOnStreamAvailable =
procedure(
const AStream: TStream)
of object;
TOnStreamAvailableDirect = reference
to procedure(
const AStream: TStream);
function GetHtml(
const AUri:
String; Stream: TStream): Boolean;
overload;
function GetHtml(
const AUri:
String):
String;
overload;
function PostHtml(
const AUri, ARequest:
String; Stream: TStream;
AContentType:
String = '
'): Boolean;
procedure RetrieveImage(ALogo:
String;
const AZip: TZipFile;
const AOnAvailable: TOnStreamAvailable;
const AOwner: TObject =
nil);
overload;
procedure RetrieveImage(ALogo:
String;
const AZip: TZipFile;
const AOnAvailable: TOnStreamAvailableDirect;
const AOwner: TObject =
nil);
overload;
procedure CancelRetrieveImage(
const AOwner: TObject);
implementation
uses System.IOUtils, System.Hash, System.NetConsts, System.Net.UrlClient
{$IFDEF USEINDY}, idHttp
{$ENDIF};
{ ============================================================================== }
function PostHtml(
const AUri, ARequest:
String; Stream: TStream;
AContentType:
String = '
'): Boolean;
var
{$IFDEF USEINDY}
http: TidHttp;
{$ELSE}
http: THttpClient;
{$ENDIF}
Source: TStringStream;
begin
Result := false;
http :=
{$IFDEF USEINDY} TidHttp.Create(
nil)
{$ELSE} THttpClient.Create
{$ENDIF};
Source := TStringStream.Create(ARequest);
try
try
if AContentType <> '
'
then
begin
{$IFDEF USEINDY}
http.Response.ContentType := AContentType;
{$ELSE}
http.ContentType := AContentType;
{$ENDIF}
end;
http.Post(AUri, Source, Stream);
Result := true;
Stream.Position := 0;
except
end;
finally
Source.Free;
http.DisPoseOf;
end;
end;
{ ============================================================================== }
function GetHtml(
const AUri:
String; Stream: TStream): Boolean;
var
{$IFDEF USEINDY}
http: TidHttp;
{$ELSE}
http: THttpClient;
{$ENDIF}
begin
Result := false;
http :=
{$IFDEF USEINDY} TidHttp.Create(
nil)
{$ELSE} THttpClient.Create
{$ENDIF};
try
try
http.Get(AUri, Stream);
Result := true;
Stream.Position := 0;
except
end;
finally
http.DisPoseOf;
end;
end;
{ ============================================================================== }
function GetHtml(
const AUri:
String):
String;
var
Stream: TStringStream;
begin
Stream := TStringStream.Create;
if GetHtml(AUri, Stream)
then
Result := Stream.DataString
else
Result := '
';
Stream.Free;
end;
{ ============================================================================== }
type
TQueueItem =
class
Filename:
String;
Callback: TOnStreamAvailableDirect;
Owner: TObject;
end;
TDownloadThread =
class(TThread)
protected
FLock: TCriticalSection;
FList: TObjectList<TQueueItem>;
FEvent: TEvent;
FCached: Boolean;
FLastRemovedOwner: TObject;
FMaxDownloads: Integer;
FThreadCount: Integer;
function GetTempFilename(
const AUri:
String):
String;
procedure Execute;
override;
procedure DoUpdate(
const AStream: TStream;
const ACallback: TOnStreamAvailableDirect;
const AOwner: TObject);
function Pop(
out AFilename:
String;
out ACallback: TOnStreamAvailableDirect;
out AOwner: TObject): Boolean;
procedure PerformDownload(
const AFilename:
String;
const ACallback: TOnStreamAvailableDirect;
const AOwner: TObject);
public
constructor Create(
const ACached: Boolean);
destructor Destroy;
override;
procedure Add(
const AFilename:
String;
const ACallback: TOnStreamAvailableDirect;
const AOwner: TObject);
procedure RemoveOwner(
const AOwner: TObject);
property MaxDownloads: Integer
read FMaxDownloads
write FMaxDownloads;
end;
{ TDownloadThread }
constructor TDownloadThread.Create(
const ACached: Boolean);
begin
inherited Create(false);
FCached := ACached;
FLock := TCriticalSection.Create;
FList := TObjectList<TQueueItem>.Create(true);
FEvent := TEvent.Create(
nil, false, false, '
');
FLastRemovedOwner :=
nil;
FMaxDownloads := MAX_DOWNLOADS;
FThreadCount := 0;
end;
destructor TDownloadThread.Destroy;
begin
Terminate;
FEvent.SetEvent;
WaitFor;
FList.Free;
FLock.Free;
FEvent.Free;
inherited;
end;
function TDownloadThread.Pop(
out AFilename:
String;
out ACallback: TOnStreamAvailableDirect;
out AOwner: TObject): Boolean;
begin
FLock.Enter;
try
Result := FList.Count > 0;
if Result
then
begin
AFilename := FList[0].Filename;
ACallback := FList[0].Callback;
AOwner := FList[0].Owner;
FList.Delete(0);
end
else
begin
AFilename := '
';
ACallback :=
nil;
AOwner :=
nil;
end;
finally
FLock.Leave;
end;
end;
procedure TDownloadThread.Add(
const AFilename:
String;
const ACallback: TOnStreamAvailableDirect;
const AOwner: TObject);
var
Item: TQueueItem;
begin
FLock.Enter;
try
Item := TQueueItem.Create;
Item.Filename := AFilename;
Item.Callback := ACallback;
Item.Owner := AOwner;
FList.Add(Item);
if FThreadCount<FMaxDownloads
then
FEvent.SetEvent;
finally
FLock.Leave;
end;
end;
function TDownloadThread.GetTempFilename(
const AUri:
string):
String;
var
ext:
string;
begin
ext := ExtractFileExt(AUri);
if (ext = '
')
or (length(ext) > 4)
then
ext := '
.png';
Result := TPath.Combine(TPath.GetTempPath,
THashMD5.GetHashString(AUri) + ext);
end;
procedure TDownloadThread.DoUpdate(
const AStream: TStream;
const ACallback: TOnStreamAvailableDirect;
const AOwner: TObject);
var
bIgnore: Boolean;
begin
AStream.Position := 0;
FLock.Enter;
bIgnore := ((FLastRemovedOwner <>
nil)
and (FLastRemovedOwner = AOwner))
or
not assigned(ACallback);
FLock.Leave;
if not bIgnore
then
TThread.Synchronize(TThread.CurrentThread,
procedure()
begin
try
ACallback(AStream);
except
end;
AStream.Free;
end)
else
AStream.Free;
end;
procedure TDownloadThread.RemoveOwner(
const AOwner: TObject);
var
i: Integer;
begin
FLock.Enter;
for i := FList.Count - 1
downto 0
do
if FList[i].Owner = AOwner
then
FList.Delete(i);
FLastRemovedOwner := AOwner;
FLock.Leave;
end;
procedure TDownloadThread.Execute;
var
Filename:
string;
Callback: TOnStreamAvailableDirect;
Owner: TObject;
begin
while not terminated
do
begin
while (FEvent.WaitFor(INFINITE) = TWaitResult.wrSignaled)
and
(Pop(Filename, Callback, Owner))
do
begin
PerformDownload(Filename, Callback, Owner);
sleep(0);
end;
sleep(10);
end;
end;
procedure TDownloadThread.PerformDownload(
const AFilename:
String;
const ACallback: TOnStreamAvailableDirect;
const AOwner: TObject);
begin
TThread.CreateAnonymousThread(
procedure()
var
bLoaded: Boolean;
TempFile:
String;
Stream: TStream;
begin
bLoaded := false;
FLock.Enter;
inc(FThreadCount);
FLock.Leave;
Stream := TMemoryStream.Create;
TempFile := GetTempFilename(AFilename);
if (FCached)
and FileExists(TempFile)
then
begin
try
TMemoryStream(Stream).LoadFromFile(TempFile);
bLoaded := true;
except
end
end;
if (
not bLoaded)
then
begin
if (FCached)
then
TMemoryStream(Stream).SaveToFile(TempFile);
if GetHtml(AFilename, Stream)
and (FCached)
then
begin
TMemoryStream(Stream).SaveToFile(TempFile)
end
else
begin
if FCached
then
DeleteFile(TempFile);
end;
end;
DoUpdate(Stream, ACallback, AOwner);
FLock.Enter;
dec(FThreadCount);
if (FList.Count > 0)
and (FThreadCount < FMaxDownloads)
then
FEvent.SetEvent;
FLock.Leave;
end).Start;
end;
var
FDownloadThread: TDownloadThread;
function DownloadThread: TDownloadThread;
begin
if not assigned(FDownloadThread)
then
FDownloadThread := TDownloadThread.Create(true);
Result := FDownloadThread;
end;
{ ============================================================================== }
procedure CancelRetrieveImage(
const AOwner: TObject);
begin
DownloadThread.RemoveOwner(AOwner);
end;
procedure RetrieveImage(ALogo:
String;
const AZip: TZipFile;
const AOnAvailable: TOnStreamAvailable;
const AOwner: TObject =
nil);
begin
if assigned(AOnAvailable)
then
RetrieveImage(ALogo, AZip,
procedure(
const AStream: TStream)
begin
AOnAvailable(AStream);
end, AOwner);
end;
procedure RetrieveImage(ALogo:
String;
const AZip: TZipFile;
const AOnAvailable: TOnStreamAvailableDirect;
const AOwner: TObject =
nil);
var
Stream: TStream;
LocalHeader: TZipHeader;
begin
if not assigned(AOnAvailable)
then
exit;
if (Pos('
://', ALogo) = 0)
and FileExists(ALogo)
then
begin
Stream := TMemoryStream.Create;
try
TMemoryStream(Stream).LoadFromFile(ALogo);
except
end;
AOnAvailable(Stream);
Stream.DisPoseOf;
end
else if assigned(AZip)
and (Pos('
zip://', ALogo) > 0)
then
begin
ALogo := StringReplace(ALogo, '
zip://', '
', [rfReplaceAll]);
if AZip.IndexOf(ALogo) > -1
then
begin
AZip.
Read(ALogo, Stream, LocalHeader);
AOnAvailable(Stream);
Stream.Free;
end;
end
else if (Pos('
http://', ALogo) > 0)
or (Pos('
https://', ALogo) > 0)
then
DownloadThread.Add(ALogo, AOnAvailable, AOwner);
end;
initialization
finalization
FreeAndNil(FDownloadThread);
end.