//////////////////////////////////////////////////////////
//
// Name: TLPLDownload
// Created: 25. Dec. 2002
// Last Revision: 14 September 2019
// Version: 1.03
//
//////////////////////////////////////////////////////////
//
// What's new:
// 1.00 - initial Release.
// 1.01 - Fixed a buffer error
// 1.02 - Added graceful closing on timeout
// 1.03 - Added DoesURLExists method to ensure an online file is available before trying to download
//        Changed DownloadFile to be a function returning a boolean depending on whether or not it was successful
//
//////////////////////////////////////////////////////////
// Copyright © 2002 - 2019, Christian Aaangel & Xander Blackstar
//////////////////////////////////////////////////////////
unit lplDownload;

interface

uses
  Windows, Messages, SysUtils, Classes, WinInet, ExtCtrls, Win32Dlg;

type
  TOnProgress = Procedure(Sender: TObject; Readed, TotalSize: Int64) of object;
  TOnComplete = Procedure(Sender: TObject) of object;
  TOnError = Procedure(Sender: TObject; ErrorCode: integer) of object;
  TlplDownload = class(TComponent)
  private
    SpeedTimer: TTimer;
    PerSec: Integer;
    fBytesPerSec: Integer;
    fAgent: string;
    fURL: String;
    fFilename: String;
    fOnProgress: TOnProgress;
    fOnComplete: TOnComplete;
    fOnError: TOnError;
    fAllowRedirect: Boolean;
    procedure SetAgent(const Value: String);
    procedure SetFilename(const Value: String);
    procedure SetURL(const Value: String);
    Procedure OnSpeedTimer(Sender: TObject);
  protected
    { Protected declarations }
  public
    Function DownloadFile: Boolean;
    Constructor Create(aOwner: TComponent); override;
    Destructor Destroy; override;
    Function PingURL(URL: string; Var ResponseStr, ResponseClass: string): Integer;
    Function GetSize(Var Size: Integer): Boolean; 
    Function GetErrorCodeDes(ErrorCode: Integer): String;
    Function DoesURLExists: Boolean;
    Function CheckUrl(url:string) : boolean;
  published
    Property Agent: String read fAgent write SetAgent;
    Property AllowRedirect: Boolean read fAllowRedirect write fAllowRedirect;
    Property Filename: String read fFilename write SetFilename;
    Property BytesPerSec: Integer read fBytesPerSec;
    Property URL: String read fURL write SetURL;
    Property OnComplete: TOnComplete read fOnComplete write fOnComplete;
    Property OnError: TOnError read fOnError write fOnError;
    Property OnProgress: TOnProgress read fOnProgress write fOnProgress;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('LPL Tools', [TlplDownload]);
end;

function lplStrPas(const Str: PChar): string;
begin
  Result := Str;
end;

{ TlplDownload }

constructor TlplDownload.Create(aOwner: TComponent);
begin
 inherited;
 
end;

destructor TlplDownload.Destroy;
begin

  inherited;
end;

Function TlplDownload.CheckUrl(url:string) : boolean;
var
  hSession, hfile: hInternet;
  dwindex,dwcodelen :dword;
  dwcode:array[1..20] of char;
  res : pchar;
begin
  if pos('http://',lowercase(url))=0 then url := 'http://' + url;
  Result := false;
  hSession := InternetOpen(PChar(fAgent), INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
  if assigned(hsession) then
  begin
    hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
    if hfile = nil then begin
     InternetCloseHandle(hSession);
     fOnError(self, 0);
     exit;
    end;
    dwIndex  := 0;
    dwCodeLen := 10;
    HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
    res := pchar(@dwcode);
    result:= (res ='200') or (Allowredirect and (Res = '302'));
    if assigned(hfile) then
      InternetCloseHandle(hfile);
    InternetCloseHandle(hsession);
  end;
end;



Function TlplDownload.DownloadFile: Boolean;
var
  hSession: HINTERNET;
  hService: HINTERNET;
  lpBuffer: array[0..1023] of Char;
  dwBytesRead: DWORD;
  aFile: TMemoryStream;
  Buf: Pointer;
  dwBufLen, dwIndex: DWord;
  TotalSize, Readed:Int64;
begin
  // Old error checking code
  //If Not(CheckURL(fURL)) Then Begin
  // exit;
  //End;

  // DoesURLExists will ping the file we are about to downloadload and if it doesn't reposnd with an OK message (HTML 200 code) will return false because it doesn't exist. Think of it as an online version of FileExists
  Result := DoesURLExists;
  If not Result then begin

   exit;
  end;

  SpeedTimer := TTimer.Create(Self);
  SpeedTimer.Interval := 1000;
  SpeedTimer.Enabled := false;
  SpeedTimer.OnTimer := OnSpeedTimer;
  hSession := InternetOpen(Pchar(fAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if hSession = nil then begin
   Error('TlplDownload' + #13#10 +
         '------------' + #13#10 +
         'URL Object doesn''t exist online' + #13#10#13#10 +
         'URL = ' + URL);
   Result := false;
   exit;
  end;
  if uppercase(Copy(fUrl, 1, 7)) <> 'HTTP://' Then fUrl := 'HTTP://' + fURL;
  aFile := TMemoryStream.Create;
  try
    if Assigned(hSession) then
    begin
      hService := InternetOpenUrl(hSession, PChar(fUrl), nil, 0, 0, 0);
      if Assigned(hService) then begin
        PerSec := 0;
        dwIndex  := 0;
        dwBufLen := 1024;
        GetMem(Buf, dwBufLen);
        TotalSize := 1024;
        If HttpQueryInfo(hService, HTTP_QUERY_CONTENT_LENGTH,
                                 Buf, dwBufLen, dwIndex) then TotalSize := StrToInt(lplStrPas(Buf));
        Readed := 0;
        SpeedTimer.Enabled := True;
        try
          while True do
          begin
            dwBytesRead := 0;
            InternetReadFile(hService, @lpBuffer, 1024, dwBytesRead);
            Inc(Readed, dwBytesRead);
            Inc(PerSec, dwBytesRead);
            if dwBytesRead = 0 then break;
            lpBuffer[dwBytesRead] := #0;
            aFile.Write(lpBuffer, dwBytesRead);
            If readed > totalsize then readed := totalsize;
            If Assigned(fOnProgress) then fOnProgress(Self, Readed, TotalSize);
          end;
        finally
          aFile.SaveToFile(Filename);
          InternetCloseHandle(hService);
          SpeedTimer.Enabled := false;
          If Assigned(fOnComplete) Then fOnComplete(Self);
        end;
      End
       else
      begin
       If Assigned(fOnError) then fOnError(Self, 500);
      End;
    end
     else
    begin
     If Assigned(fOnError) then fOnError(Self, 500);
    End;
  finally
   InternetCloseHandle(hSession);
  End;
  FreeAndnil(aFile);
  If assigned(speedtimer) then begin
   FreeAndnil(SpeedTimer);
  end;
end;

procedure TlplDownload.SetAgent(const Value: String);
begin
  fAgent := Value;
end;

procedure TlplDownload.SetFilename(const Value: String);
begin
  fFilename := Value;
end;

procedure TlplDownload.SetURL(const Value: String);
begin
  fURL := Value;
end;

function TlplDownload.DoesURLExists: Boolean;
var
 RC, RS: String;
begin
 Result := PingURL(URL, RC, RS) = 200;
end;

procedure TlplDownload.OnSpeedTimer(Sender: TObject);
begin
 fBytesPerSec := PerSec;
 PerSec := 0;
end;

function TlplDownload.PingURL(URL: String; Var ResponseStr, ResponseClass: string): Integer;
var
  hSession, hfile: hInternet;
  dwindex,dwcodelen :dword;
  dwcode:array[1..20] of char;
  res : pchar;
begin
  if pos('http://',lowercase(url))=0 then url := 'http://' + url;
  Result := -1;
  hSession := InternetOpen(PChar(fAgent), INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
  if assigned(hsession) then
  begin
    hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
    if hfile = nil then begin
     InternetCloseHandle(hSession);
     ResponseStr := 'Timeout';
     ResponseClass := 'Connection error';
     exit;
    end;
    dwIndex  := 0;
    dwCodeLen := 10;
    HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
    res := pchar(@dwcode);
    result:= StrToInt(Res);
    Case Result of
     100: ResponseStr := 'Continue';
     101: ResponseStr := 'Switching Protocol';
     200: ResponseStr := 'OK';
     201: ResponseStr := 'Created';
     202: ResponseStr := 'Accepted';
     203: ResponseStr := 'Non-Authoritative Information';
     204: ResponseStr := 'No Content';
     205: ResponseStr := 'Reset Content';
     206: ResponseStr := 'Partial Content';
     300: ResponseStr := 'Multiple Choice';
     301: ResponseStr := 'Moved Permanently';
     302: ResponseStr := 'Found';
     303: ResponseStr := 'See Other';
     304: ResponseStr := 'Not Modified';
     305: ResponseStr := 'Use Proxy';
     306: ResponseStr := '(Unused)';
     307: ResponseStr := 'Temporary Redirect';
     400: ResponseStr := 'Bad Request';
     401: ResponseStr := 'Unauthorized';
     402: ResponseStr := 'Payment Required';
     403: ResponseStr := 'Forbidden';
     404: ResponseStr := 'Not Found';
     405: ResponseStr := 'Method Not Allowed';
     406: ResponseStr := 'Not Acceptable';
     407: ResponseStr := 'Proxy Authentication Required';
     408: ResponseStr := 'Request Timeout';
     409: ResponseStr := 'Conflict';
     410: ResponseStr := 'Gone';
     411: ResponseStr := 'Length Required';
     412: ResponseStr := 'Precondition Failed';
     413: ResponseStr := 'Request Entity Too Large';
     414: ResponseStr := 'Request-Url too long';
     415: ResponseStr := 'Unsupported Media Type';
     416: ResponseStr := 'Requested Range Not satisfiable';
     417: ResponseStr := 'Expectation Failed';
     500: ResponseStr := 'Internal Server Error';
     501: ResponseStr := 'Not Implementet';
     502: ResponseStr := 'Bad GateWay';
     503: ResponseStr := 'Service Unavailable';
     504: ResponseStr := 'Gateway Timeout';
     505: ResponseStr := 'HTTP Version Not Supported';
    End;
    If (Result > 99) and (Result < 199) Then ResponseClass := 'Informational';
    If (Result > 199) and (Result < 299) Then ResponseClass := 'Successful';
    If (Result > 299) and (Result < 399) Then ResponseClass := 'Redirection';
    If (Result > 399) and (Result < 499) Then ResponseClass := 'Error';
    If (Result > 499) and (Result < 599) Then ResponseClass := 'Server Error';
    if assigned(hfile) then
      InternetCloseHandle(hfile);
    InternetCloseHandle(hsession);
  end;
end;

function TlplDownload.GetErrorCodeDes(ErrorCode: Integer): String;
begin
 Result := 'Undefined Error';
    Case ErrorCode of
     000: Result := 'Timeout';
     100: Result := 'Continue';
     101: Result := 'Switching Protokol';
     200: Result := 'OK';
     201: Result := 'Created';
     202: Result := 'Accepted';
     203: Result := 'Non-Authoritative Information';
     204: Result := 'No Content';
     205: Result := 'Reset Content';
     206: Result := 'Partial Content';
     300: Result := 'Multiple Choice';
     301: Result := 'Moved Permanently';
     302: Result := 'Found';
     303: Result := 'See Other';
     304: Result := 'Not Modified';
     305: Result := 'Use Proxy';
     306: Result := '(Unused)';
     307: Result := 'Temporary Redirect';
     400: Result := 'Bad Request';
     401: Result := 'Unauthorized';
     402: Result := 'Payment Required';
     403: Result := 'Forbidden';
     404: Result := 'Not Found';
     405: Result := 'Method Not Allowed';
     406: Result := 'Not Acceptable';
     407: Result := 'Proxy Authentication Required';
     408: Result := 'Request Timeout';
     409: Result := 'Conflict';
     410: Result := 'Gone';
     411: Result := 'Length Required';
     412: Result := 'Precondition Failed';
     413: Result := 'Request Entity Too Large';
     414: Result := 'Request-Url too long';
     415: Result := 'Unsupported Media Type';
     416: Result := 'Requested Range Not satisfiable';
     417: Result := 'Expectation Failed';
     500: Result := 'Internal Server Error';
     501: Result := 'Not Implementet';
     502: Result := 'Bad GateWay';
     503: Result := 'Service Unavailable';
     504: Result := 'Gateway Timeout';
     505: Result := 'HTTP Version Not Supported';
    End;
end;

function TlplDownload.GetSize(var Size: Integer): Boolean;
var
  hSession: hInternet;
  hService: HINTERNET;
  Buf: Pointer;
  dwBufLen, dwIndex: DWord;
begin
 Result := False;
 hSession := InternetOpen(Pchar(fAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
 if uppercase(Copy(fUrl, 1, 7)) <> 'HTTP://' Then fUrl := 'HTTP://' + fURL;
 if Assigned(hSession) then begin
  hService := InternetOpenUrl(hSession, PChar(fUrl), nil, 0, 0, 0);
  if Assigned(hService) then begin
   dwIndex  := 0;
   dwBufLen := 1024;
   GetMem(Buf, dwBufLen);
   If HttpQueryInfo(hService, HTTP_QUERY_CONTENT_LENGTH, Buf, dwBufLen, dwIndex) then Begin
    Result := True;
    Size := StrToInt(lplStrPas(Buf));
   End;
  end;
  InternetCloseHandle(hService);
 end;
 InternetCloseHandle(hSession);
end;

end.
