initial commit from lost SVN repo
This commit is contained in:
fatalerrors
567
common/udownload.pas
Normal file
567
common/udownload.pas
Normal file
@@ -0,0 +1,567 @@
|
||||
{
|
||||
********************************************************************************
|
||||
|
||||
SPackGui
|
||||
Copyright (C) 2012-2013 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
|
||||
Copyright (C) <date> <add your name and mail address here>
|
||||
|
||||
Parts inspired from AstroSurf souce code:
|
||||
Copyright (C) 2006 Patrick Chevalley <pch@freesurf.ch>
|
||||
|
||||
http://www.geoffray-levasseur.org/
|
||||
http://0.tuxfamilly.org/
|
||||
|
||||
This software is governed by the CeCILL license under French law and
|
||||
abiding by the rules of distribution of free software. You can use,
|
||||
modify and/ or redistribute the software under the terms of the CeCILL
|
||||
license as circulated by CEA, CNRS and INRIA at the following URL
|
||||
"http://www.cecill.info".
|
||||
|
||||
As a counterpart to the access to the source code and rights to copy,
|
||||
modify and redistribute granted by the license, users are provided only
|
||||
with a limited warranty and the software's author, the holder of the
|
||||
economic rights, and the successive licensors have only limited
|
||||
liability.
|
||||
|
||||
In this respect, the user's attention is drawn to the risks associated
|
||||
with loading, using, modifying and/or developing or reproducing the
|
||||
software by the user in light of its specific status of free software,
|
||||
that may mean that it is complicated to manipulate, and that also
|
||||
therefore means that it is reserved for developers and experienced
|
||||
professionals having in-depth computer knowledge. Users are therefore
|
||||
encouraged to load and test the software's suitability as regards their
|
||||
requirements in conditions enabling the security of their systems and/or
|
||||
data to be ensured and, more generally, to use and operate it in the
|
||||
same conditions as regards security.
|
||||
|
||||
The fact that you are presently reading this means that you have had
|
||||
knowledge of the CeCILL license and that you accept its terms.
|
||||
|
||||
********************************************************************************
|
||||
|
||||
Description:
|
||||
simple downloader class
|
||||
|
||||
********************************************************************************
|
||||
}
|
||||
unit uDownload;
|
||||
|
||||
{$include defines.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, HTTPsend, FTPSend, blcksock;
|
||||
|
||||
type
|
||||
TDownloadProtocol = (prHttp, prFtp);
|
||||
TDownloadProc = procedure of object;
|
||||
TDownloadFeedback = procedure (Txt: string) of object;
|
||||
TDownloadResult = (drNone, drDownloading, drError, drDone,
|
||||
drCanceled, drPaused);
|
||||
|
||||
TDownloader = class(TObject)
|
||||
private
|
||||
FDownloadFeedback: TDownloadFeedback;
|
||||
FProtocol: TDownloadProtocol;
|
||||
FSockReadCount, FSockWriteCount: Integer;
|
||||
FLastRead, FLastWrite: integer;
|
||||
FUrl, FFirstUrl: string;
|
||||
FDwlOk: Boolean;
|
||||
FHttp: THTTPSend;
|
||||
FFtp: TFTPSend;
|
||||
FResponse: string;
|
||||
FFile: string;
|
||||
FProxy, FProxyPort, FProxyUser, FProxyPass: string;
|
||||
FSocksProxy, FSocksType: string;
|
||||
FFWMode: Integer;
|
||||
FFWPassive: Boolean;
|
||||
FUserName, FPassword: string;
|
||||
FFWhost, FFWport, FFWUsername, FFWPassword: string;
|
||||
FFileSize: LongInt;
|
||||
FStatus: string;
|
||||
FFtpDir, FFtpFile: string;
|
||||
FState: TDownloadResult;
|
||||
FPaused: Boolean;
|
||||
FProgressText: string;
|
||||
FOnDownloadComplete: TDownloadProc;
|
||||
FOnProgress: TDownloadProc;
|
||||
function InitHttp(const GetSize: Boolean): Boolean;
|
||||
function InitFtp(const GetSize: Boolean): Boolean;
|
||||
function GetDownloadedSize: LongInt;
|
||||
procedure SetUrl(const Value: string);
|
||||
procedure DoDownload;
|
||||
procedure SockStatus(Sender: TObject; Reason: THookSocketReason;
|
||||
const Value: string);
|
||||
procedure FTPStatus(Sender: TObject; Response: Boolean;
|
||||
const Value: string);
|
||||
protected
|
||||
procedure HTTPComplete;
|
||||
procedure FTPComplete;
|
||||
procedure ProgressReport;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
function StartDownload: Boolean;
|
||||
procedure Cancel;
|
||||
procedure Pause;
|
||||
property URL: string read FUrl write SetUrl;
|
||||
property SaveToFile: string read FFile write FFile;
|
||||
property ResponseText: string read FResponse;
|
||||
property HttpProxy: string read FProxy write FProxy ;
|
||||
property HttpProxyPort: string read FProxyPort write FProxyPort;
|
||||
property HttpProxyUser: string read FProxyUser write FProxyUser;
|
||||
property HttpProxyPass: string read FProxyPass write FProxyPass;
|
||||
property SocksProxy: string read FSocksproxy write FSocksProxy;
|
||||
property SocksType: string read FSocksType write FSocksType;
|
||||
property FtpUserName: string read FUserName write FUserName;
|
||||
property FtpPassword: string read FPassword write FPassword;
|
||||
property FtpFwMode: integer read FFWMode write FFWMode;
|
||||
property FtpFwPassive: Boolean read FFWpassive write FFWpassive;
|
||||
property FtpFwHost: string read FFWhost write FFWhost;
|
||||
property FtpFwPort: string read FFWport write FFWport;
|
||||
property FtpFwUserName: string read FFWUsername write FFWUsername;
|
||||
property FtpFwPassword: string read FFWPassword write FFWPassword;
|
||||
property FileSize: LongInt read FFileSize;
|
||||
property Status: string read FStatus;
|
||||
property DownloadedSize: LongInt read GetDownloadedSize;
|
||||
property State: TDownloadResult read FState;
|
||||
property OnFeedback: TDownloadFeedback read FDownloadFeedback
|
||||
write FDownloadFeedback;
|
||||
property OnDownloadComplete: TDownloadProc read FOnDownloadComplete
|
||||
write FOnDownloadComplete;
|
||||
property OnProgress: TDownloadProc read FOnProgress write FOnProgress;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
uDebug, uCommon, uStrings, Forms;
|
||||
|
||||
|
||||
procedure TDownloader.DoDownload;
|
||||
begin
|
||||
PrintLnDbg(rsDebugDownloadStarted);
|
||||
try
|
||||
FSockReadCount := 0;
|
||||
FSockWriteCount := 0;
|
||||
FLastRead := 0;
|
||||
FLastWrite := 0;
|
||||
if FProtocol = prHttp then
|
||||
begin
|
||||
FHttp.Sock.OnStatus := @SockStatus;
|
||||
FDwlOk := FHttp.HTTPMethod('GET', FUrl);
|
||||
end;
|
||||
if FProtocol = prFtp then
|
||||
begin
|
||||
FFtp.OnStatus := @FTPStatus;
|
||||
if FFtp.Login then
|
||||
begin
|
||||
FFtp.ChangeWorkingDir(FFtpDir);
|
||||
FDwlOk := FFtp.RetrieveFile(FFtpFile, False);
|
||||
end;
|
||||
end;
|
||||
if Assigned(FOnDownloadComplete) then
|
||||
FOnDownloadComplete;
|
||||
except
|
||||
if FProtocol = prHttp then
|
||||
PrintLnDbg(Format(rsErrorDownloadingFailed, [FUrl]), vlLow);
|
||||
if FProtocol = prFtp then
|
||||
PrintLnDbg(Format(rsErrorDownloadingFailed, [FFtpFile]), vlLow);
|
||||
FState := drError;
|
||||
end;
|
||||
PrintLnDbg(rsDebugDownloadFinished);
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.SockStatus(Sender: TObject;
|
||||
Reason: THookSocketReason; const Value: string);
|
||||
var
|
||||
ReasonTxt: string;
|
||||
begin
|
||||
ReasonTxt := '';
|
||||
case Reason of
|
||||
HR_ResolvingBegin: ReasonTxt := rsNetStatResolving + Value;
|
||||
HR_Connect: ReasonTxt := rsNetStatConnect + Value;
|
||||
HR_Accept: ReasonTxt := rsNetStatAccept + Value;
|
||||
HR_ReadCount: begin
|
||||
FSockReadCount := FSockReadCount + StrToInt(Value);
|
||||
if (FSockReadCount - FLastRead) > 100000 then
|
||||
begin
|
||||
ReasonTxt := rsNetStatReadBytes + IntToStr(FSockReadCount);
|
||||
FLastRead := FSockReadCount;
|
||||
end;
|
||||
end;
|
||||
HR_WriteCount: begin
|
||||
FSockWriteCount := FSockWriteCount + StrToInt(Value);
|
||||
ReasonTxt := rsNetStatRequesting;
|
||||
end;
|
||||
else
|
||||
ReasonTxt := '';
|
||||
end;
|
||||
if (ReasonTxt > '') and assigned(FOnProgress) then
|
||||
begin
|
||||
FProgressText := ReasonTxt;
|
||||
FOnProgress;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.FTPStatus(Sender: TObject; Response: Boolean;
|
||||
const Value: string);
|
||||
begin
|
||||
if Response and Assigned(FOnProgress) then
|
||||
begin
|
||||
FProgressText := Value;
|
||||
FOnProgress;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TDownloader.InitHttp(const GetSize: Boolean): Boolean;
|
||||
var
|
||||
I, N: integer;
|
||||
const
|
||||
CL = 'CONTENT-LENGTH';
|
||||
begin
|
||||
Result := True;
|
||||
try
|
||||
FResponse := '';
|
||||
FHttp.Clear;
|
||||
FHttp.Sock.SocksIP := '';
|
||||
FHttp.ProxyHost := '';
|
||||
if FSocksProxy <> '' then
|
||||
begin
|
||||
FHttp.Sock.SocksIP := FSocksProxy;
|
||||
if FProxyPort <> '' then
|
||||
FHttp.Sock.SocksPort := FProxyPort;
|
||||
if FSocksType = 'Socks4' then
|
||||
FHttp.Sock.SocksType := ST_Socks4
|
||||
else
|
||||
FHttp.Sock.SocksType := ST_Socks5;
|
||||
if FProxyUser <> '' then
|
||||
FHttp.Sock.SocksUsername := FProxyUser;
|
||||
if FProxyPass <> '' then
|
||||
FHttp.Sock.SocksPassword := FProxyPass;
|
||||
end else
|
||||
if FProxy <> '' then
|
||||
begin
|
||||
FHttp.ProxyHost := FProxy;
|
||||
if FProxyPort <> '' then
|
||||
FHttp.ProxyPort := FProxyPort;
|
||||
if FProxyUser <> '' then
|
||||
FHttp.ProxyUser := FProxyUser;
|
||||
if FProxyPass <> '' then
|
||||
FHttp.ProxyPass := FProxyPass;
|
||||
end;
|
||||
if GetSize then
|
||||
if FHttp.HTTPMethod('HEAD', FUrl) then
|
||||
try
|
||||
for I := 0 to FHttp.Headers.Count - 1 do
|
||||
begin
|
||||
N := Pos(CL, UpperCase(FHttp.Headers[I]));
|
||||
if N <> 0 then
|
||||
begin
|
||||
FFileSize := StrToInt(Trim(Copy(FHttp.Headers[I],
|
||||
N + Length(CL) + 1,
|
||||
Length(FHttp.Headers[I]) - Length(CL) - N)));
|
||||
PrintLnDbg(Format(rsInfoInitializedDownload, [FUrl,
|
||||
DispSize(FFileSize)]), vlLow);
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
except
|
||||
FFileSize := -1;
|
||||
end else //can't get the filesize from the server
|
||||
FFileSize := -1;
|
||||
except
|
||||
Result := False;
|
||||
FState := drError;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TDownloader.InitFtp(const GetSize: Boolean): Boolean;
|
||||
var
|
||||
Buf: string;
|
||||
I: integer;
|
||||
begin
|
||||
Result := True;
|
||||
try
|
||||
FResponse := '';
|
||||
I := Pos('://', FUrl);
|
||||
Buf := Copy(Furl, I + 3, Length(FUrl) - I - 2);
|
||||
I := Pos('/', Buf);
|
||||
FFtp.TargetHost := Copy(Buf, 1, I - 1);
|
||||
FFtp.PassiveMode := FFWpassive;
|
||||
if FUserName <> '' then
|
||||
FFtp.UserName := FUserName
|
||||
else
|
||||
FFtp.UserName := 'anonymous';
|
||||
FFtp.Password := FPassword;
|
||||
FFtp.FWMode := FFWMode;
|
||||
if FFWhost <> '' then
|
||||
FFtp.FWHost := FFWHost;
|
||||
if FFWport <> '' then
|
||||
FFtp.FWPort := FFWPort;
|
||||
if FFWUsername <> '' then
|
||||
FFtp.FWUsername := FFWUsername;
|
||||
if FFWPassword <> '' then
|
||||
FFtp.FWPassword := FFWPassword;
|
||||
Buf := Copy(Buf, I, Length(Buf) - I + 1);
|
||||
I := LastDelimiter('/', Buf);
|
||||
FFtpDir := Copy(Buf, 1, I);
|
||||
FFtpFile := Copy(Buf, I + 1, Length(Buf) - I);
|
||||
FFtp.DirectFile := True;
|
||||
FFtp.DirectFileName := FFile;
|
||||
if GetSize then
|
||||
begin
|
||||
if FFtp.Login then
|
||||
begin
|
||||
FFtp.ChangeWorkingDir(FFtpDir);
|
||||
FFileSize := FFtp.FileSize(FFtpFile);
|
||||
FFtp.Logout;
|
||||
end else
|
||||
FFileSize := -1;
|
||||
PrintLnDbg(Format(rsInfoInitializedDownload, [FUrl,
|
||||
DispSize(FFileSize)]), vlLow);
|
||||
end;
|
||||
except
|
||||
Result := False;
|
||||
FState := drError;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TDownloader.GetDownloadedSize: Longint;
|
||||
begin
|
||||
Result := 0;
|
||||
case FProtocol of
|
||||
prHttp: Result := FHttp.Sock.RecvCounter;
|
||||
prFtp: Result := FFtp.DSock.RecvCounter;
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.SetUrl(const Value: string);
|
||||
begin
|
||||
FUrl := Value;
|
||||
if Trim(FUrl) <> '' then
|
||||
if Copy(FUrl, 1, 7) = sHttpPrefix then
|
||||
InitHttp(True)
|
||||
else
|
||||
if Copy(Furl, 1, 6) = sFtpPrefix then {$warning What about sftp ?}
|
||||
InitFtp(True);
|
||||
end;
|
||||
|
||||
|
||||
constructor TDownloader.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FHttp := THTTPSend.Create;
|
||||
FFtp := TFTPSend.Create;
|
||||
FProxy := '';
|
||||
FSocksProxy := '';
|
||||
FFWMode := 0;
|
||||
FFWpassive := True;
|
||||
FStatus := '';
|
||||
FResponse := '';
|
||||
FState := drNone;
|
||||
FUserName := '';
|
||||
FPassword := '';
|
||||
FPaused := False;
|
||||
FDwlOk := False;
|
||||
end;
|
||||
|
||||
|
||||
destructor TDownloader.Destroy;
|
||||
begin
|
||||
FHttp.Free;
|
||||
FFtp.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.Cancel;
|
||||
begin
|
||||
if FProtocol = prHttp then
|
||||
begin
|
||||
FHttp.Sock.OnStatus := nil;
|
||||
FHttp.Abort;
|
||||
end;
|
||||
if FProtocol = prFtp then
|
||||
begin
|
||||
FFtp.Sock.OnStatus := nil;
|
||||
FFtp.OnStatus := nil;
|
||||
FFtp.Abort;
|
||||
end;
|
||||
FState := drCanceled;
|
||||
FOnProgress := nil;
|
||||
FOnDownloadComplete := nil;
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.Pause;
|
||||
begin
|
||||
if (FState <> drDownloading) and (FState <> drPaused) then
|
||||
Exit;
|
||||
{ if FPaused then
|
||||
begin
|
||||
FDownloadDaemon.Resume;
|
||||
FPaused := False;
|
||||
end else
|
||||
begin
|
||||
FDownloadDaemon.Suspend;
|
||||
FPaused := True;
|
||||
end;
|
||||
if FPaused then
|
||||
FState := drPaused
|
||||
else
|
||||
FState := drDownloading;} {$warning pause system need complete rewrite}
|
||||
end;
|
||||
|
||||
|
||||
function TDownloader.StartDownload: Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if Trim(FUrl) = '' then
|
||||
raise Exception.Create(rsExceptEmptyAddress);
|
||||
if Copy(FUrl, 1, 7) = sHttpPrefix then
|
||||
begin // HTTP protocol
|
||||
if InitHttp(False) then
|
||||
try
|
||||
FProtocol := prHttp;
|
||||
FOnProgress := @ProgressReport;
|
||||
FOnDownloadComplete := @HTTPComplete;
|
||||
FState := drDownloading;
|
||||
DoDownload;
|
||||
except
|
||||
FState := drError;
|
||||
Result := False;
|
||||
end else
|
||||
begin
|
||||
FState := drError;
|
||||
Result := False;
|
||||
end;
|
||||
end else
|
||||
begin // FTP protocol
|
||||
if Copy(Furl, 1, 6) <> sFtpPrefix then
|
||||
begin
|
||||
FState := drError;
|
||||
Result := False;
|
||||
raise Exception.Create(rsExceptUnsupportedProtocol);
|
||||
end;
|
||||
if InitFtp(False) then
|
||||
try
|
||||
FProtocol := prFtp;
|
||||
FOnProgress := @ProgressReport;
|
||||
FOnDownloadComplete := @FTPComplete;
|
||||
FState := drDownloading;
|
||||
DoDownload;
|
||||
except
|
||||
FState := drError;
|
||||
Result := False;
|
||||
end else
|
||||
begin
|
||||
FState := drError;
|
||||
Result := False;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.HTTPComplete;
|
||||
var
|
||||
Ok: Boolean;
|
||||
I: Integer;
|
||||
NewUrl: string;
|
||||
begin
|
||||
Ok := FDwlOk;
|
||||
if Ok and (((FHttp.ResultCode >= 100) and (FHttp.ResultCode <= 299)) or
|
||||
(FHttp.ResultCode = 0)) then
|
||||
begin // success
|
||||
FHttp.Document.Position := 0;
|
||||
FHttp.Document.SaveToFile(FFile);
|
||||
FResponse := 'Finished: ' + FStatus;
|
||||
if Assigned(FDownloadFeedback) then
|
||||
FDownloadFeedback(FResponse);
|
||||
FHttp.Clear;
|
||||
if Assigned(FDownloadFeedback) then
|
||||
FDownloadFeedback(FStatus);
|
||||
FState := drDone;
|
||||
end else
|
||||
if (FHttp.ResultCode = 301) or (FHttp.ResultCode = 302) or
|
||||
(FHttp.ResultCode = 307) then
|
||||
begin
|
||||
for I := 0 to FHttp.Headers.Count - 1 do
|
||||
begin
|
||||
if UpperCase(Copy(FHttp.Headers[I], 1, 9)) = 'LOCATION:' then
|
||||
begin
|
||||
NewUrl := Trim(Copy(FHttp.Headers[I], 10, 9999));
|
||||
if (NewUrl = FUrl) or (NewUrl = FFirstUrl) then
|
||||
begin
|
||||
Ok := False;
|
||||
FState := drError;
|
||||
end else
|
||||
begin
|
||||
FStatus := 'Redirect to: ' + NewUrl;
|
||||
if Assigned(FDownloadFeedback) then
|
||||
FDownloadFeedback(FStatus);
|
||||
FUrl := NewUrl;
|
||||
StartDownload;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Ok := False;
|
||||
end else
|
||||
begin // error
|
||||
Ok := False;
|
||||
if FHttp.ResultCode = 0 then
|
||||
FResponse := 'Finished: '+ FStatus +' / Error: Timeout '+
|
||||
FHttp.ResultString
|
||||
else
|
||||
FResponse := 'Finished: '+ FStatus + ' / Error: '+
|
||||
IntToStr(FHttp.ResultCode) + ' ' + FHttp.ResultString;
|
||||
FStatus := FResponse;
|
||||
FHttp.Clear;
|
||||
if FState <> drCanceled then
|
||||
FState := drError;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.FTPComplete;
|
||||
var
|
||||
Ok: Boolean;
|
||||
begin
|
||||
Ok := FDwlOk;
|
||||
FResponse := FStatus;
|
||||
if Ok then
|
||||
begin
|
||||
FFtp.Sock.OnStatus := nil;
|
||||
FFtp.OnStatus := nil;
|
||||
FFtp.Logout;
|
||||
FState := drDone;
|
||||
end else
|
||||
begin
|
||||
FFtp.Sock.OnStatus := nil;
|
||||
FFtp.OnStatus := nil;
|
||||
FFtp.Abort;
|
||||
FStatus := FResponse;
|
||||
if FState <> drCanceled then
|
||||
FState := drError;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TDownloader.ProgressReport;
|
||||
begin
|
||||
FStatus := FProgressText;
|
||||
if Assigned(FDownloadFeedback) then
|
||||
FDownloadFeedback(FStatus);
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
end.
|
||||
Reference in New Issue
Block a user