0linux/common/udownload.pas

{
********************************************************************************

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.