Witam. Tak na szybko, bo życie w biegu. Wyedytowałem swój post i wklejam na szybko przed wyjściem do pracy popełniony moduł. Z obsługą wątków radzę sobie słabo Cóż - wieki nic nie kodowałem regularnie. Na oko wszystko tutaj działa jak należy. Ale chciałbym Was podpytać czy coś tutaj w kodzie można było by poprawić. Jak zrobić wznawianie ewentualne i czy są poważne błędy? I dodam że testowy plik po HTTPS można mieć stąd: https://speed.hetzner.de/100MB.bin
unit https_download;
interface
uses
Windows, WinInet, Classes, SysUtils, httpsend, ssl_openssl;
type
TProgressEvent = procedure(Sender : TObject; DownloadedBytes, TotalSize : DWORD) of object;
THttpsDownload = class(TThread)
private
FUrl : string;
FOutFile : file;
FOutDir : string;
FFileName : string;
FUserAgent : string;
FSynHttp : THttpSend;
FTotalFileSize : DWORD;
FDownloadedBytes : DWORD;
FOnProgress : TProgressEvent;
protected
procedure DoProgress;
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
published
procedure Cancel;
property FileSize : DWORD read FDownloadedBytes;
property OnProgress : TProgressEvent read FOnProgress write FOnProgress;
procedure DownloadFile(ArgUrl : string; ArgFileName : string; ArgOutDir : string = ''; ArgUserAgent : string = '');
end;
implementation
const
CR = #13;
Https_Prefix = 'https:'#47#47;
User_Agent = 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:46.0) Gecko/20100101 Firefox/46.0';
procedure SMsg(Text : string);
begin
MessageBox(GetActiveWindow, PChar(Text), PChar('Test'), MB_OK);
end;
function ExtractFileNameFromUrl(Url : string) : string;
var
I : integer;
begin
for I := Length(Url) downto 1 do
begin
if Copy(Url, I, 1) = '/' then
begin
Delete(Url, 1, I);
end;
Result := Url;
end;
end;
function SimpleParse(StrBegin, StrEnd, Str : string) : string;
var
B, E : integer;
begin
Result := '';
if StrBegin = '' then
begin
B := 1;
end
else
begin
B := Pos(StrBegin, Str);
end;
if B > 0 then
begin
Str := Copy(Str, B + Length(StrBegin), MaxInt);
if StrEnd = '' then
begin
E := Length(Str) + 1;
end
else
begin
E := Pos(StrEnd, Str);
end;
if E > 0 then
begin
Result := Copy(Str, 1, E - 1);
end;
end;
end;
procedure THttpsDownload.Execute;
const
BufferSize = 1024;
Content_Length_Prefix = 'Content-Length: ';
var
Tmp : integer;
BufferLen : DWORD;
HSession, HUrl : HInternet;
Header, DestFileName : string;
Buffer : array[1..BufferSize] of Byte;
begin
FSynHttp := THttpSend.Create;
with FSynHttp do
begin
Sock.CreateWithSSL(TSSLOpenSSL);
Sock.SSLDoConnect;
Protocol := '1.1';
UserAgent := FUserAgent;
HTTPMethod('HEAD', FUrl);
Header := Headers.Text;
Tmp := Pos(Content_Length_Prefix, Header);
if Tmp > 0 then
begin
Tmp := Tmp + Length(Content_Length_Prefix);
Header := Copy(Header, Tmp, MaxInt);
Tmp := 1;
while Header[Tmp] <> CR do
begin
Tmp := Tmp + 1;
end;
Delete(Header, Tmp, MaxInt);
Val(Header, FTotalFileSize, Tmp);
end;
DestFileName := SimpleParse('Content-Disposition: attachment; filename="', '"', Headers.Text);
end;
if DestFileName <> '' then
begin
FFileName := DestFileName;
end
else
begin
DestFileName := ExtractFileNameFromUrl(FUrl);
if DestFileName = '/' then
begin
DestFileName := FFileName;
end;
end;
FreeAndNil(FSynHttp);
FDownloadedBytes := 0;
HSession := InternetOpen(PChar(User_Agent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
InternetConnect(hSession, PChar(FUrl), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
try
HUrl := InternetOpenURL(hSession, PChar(FUrl), nil, 0, INTERNET_FLAG_DONT_CACHE or INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_RELOAD, 0);
try
AssignFile(FOutFile, FOutDir + DestFileName);
Rewrite(FOutFile, 1);
try
repeat
InternetReadFile(HUrl, @Buffer, SizeOf(Buffer), BufferLen);
FDownloadedBytes := FDownloadedBytes + BufferLen;
BlockWrite(FOutFile, Buffer, BufferLen);
if Assigned(FOnProgress) then
begin
Synchronize(DoProgress);
end;
until BufferLen = 0;
finally
CloseFile(FOutFile);
end;
finally
InternetCloseHandle(HUrl);
end
finally
InternetCloseHandle(HSession);
end;
end;
procedure THttpsDownload.DoProgress;
begin
FOnProgress(Self, FDownloadedBytes, FTotalFileSize);
end;
constructor THttpsDownload.Create;
begin
inherited Create(True);
FDownloadedBytes := 0;
end;
destructor THttpsDownload.Destroy;
begin
try
CloseFile(FOutFile);
finally
if FSynHttp <> nil then
begin
FreeAndNil(FSynHttp);
end;
end;
end;
procedure THttpsDownload.Cancel;
begin
Self.Suspend;
Self.Free;
end;
procedure THttpsDownload.DownloadFile(ArgUrl : string; ArgFileName : string; ArgOutDir : string = ''; ArgUserAgent : string = '');
begin
if Pos(Https_Prefix, ArgUrl) = 1 then
begin
FUrl := ArgUrl;
FFileName := ArgFileName;
if ArgOutDir = '' then
begin
FOutDir := '.\';
end;
if ArgUserAgent = '' then
begin
FUserAgent := User_Agent;
end
else
begin
FUserAgent := ArgUserAgent;
end;
Self.Resume;
end;
end;
end.