A http file downloader component

unit http_download;

{ http downloading component. }
// issue: User wants to cancel out from a file prompt?  How to stop this?

interface
  uses forms, classes, windows, messages, sysutils, winhttp, dialogs;

  {$R HTTP_RES.DCR}

const
  WM_WEBFILE = WM_APP + $20;
  WM_WEBPROGRESS = WM_APP + $21;
  WM_WEBFINISHED = WM_APP + $22;

type
  DWord = Longint;
  int64 = comp;
  TWebDownloader = class(TThread)
    private
      szBuffer: array[1..32768] of byte;
      FSizeRead: DWord;
      hConnect, hRequest, hSession: HInternet;
      LocalFName: string;

      procedure CleanUp;
      function FileSizeEx(savefile: string): Int64;
      function GetSaveFile(inURL: string): String;
      function GetContentLength(URLHandle: HINTERNET): Int64;
      function GetFullURL(URLHandle: HINTERNET; fURL: string): String;
      function GetStatusText(URLHandle: HINTERNET): string;
      function GetStatusCode(URLHandle: HINTERNET): integer;
      function GetURLHost(inURL: string): string;
      function GetURLPath(inURL: string): String;
      function GetRangeString: string;
   public
      PropEvent: THandle;
      Win_Handle: THandle;
      DownloadSize: Int64;
      StatusCode: integer;
      StatusText: string;
      UserAgent: string;
      URL: string;
      SaveFilePath: string;
      UseDownloadRanges: boolean;
      ResumeDownload: Boolean;
      HighRange, LowRange: Int64;
   protected
      procedure Execute; override;
   end;

  TDownloadProgressEvent = procedure (Sender: TObject; DownloadUnit: DWord; DownloadSize: Comp) of object;
  TFilePromptEvent = procedure (Sender: TObject; var LocalFilePath, LocalFileName: string) of object;
  THttpDownload = class(TComponent)
    private
      FUserAgent: string;
      FLowRange: Int64;
      FHighRange: Int64;
      FURL: string;
      FSaveFilePath: string;
      FUseDownloadRanges: Boolean;
      FResumeDownload: boolean;
      FHandle: THandle;

      FOnProgress: TDownloadProgressEvent;
      FOnFilePrompt: TFilePromptEvent;
      FOnCompleted: TNotifyEvent;

      FDownloader: TWebDownloader;
    public
      DownloadSize: Int64;
      StatusCode: integer;
      StatusText: string;

      procedure DownloadFile;
      procedure DownloadCancel;
      procedure DownloadPause;
      procedure DownloadResume;
      procedure WaitForDownload;

      Constructor Create(AOwner: TComponent); override;
      Destructor Destroy; override;
    protected
      procedure Loaded; override;
      procedure Window_Handler(var msg: TMessage); virtual;
    published
      property URL: string read FURL write FURL;
      property SaveFilePath: string read FSaveFilePath write FSaveFilePath;
      property UseDownloadRanges: boolean read FUseDownloadRanges
          write FUseDownloadRanges default false;
      property ResumeDownload: boolean read FResumeDownload
          write FResumeDownload default false;
      property LowRange: Int64 read FLowRange write FLowRange;
      property HighRange: Int64 read FHighRange write FHighRange;
      property UserAgent: string read FUserAgent write FUserAgent;
      property OnProgress: TDownloadProgressEvent read FOnProgress write FOnProgress;
      property OnFilePrompt: TFilePromptEvent read FOnFilePrompt write FOnFilePrompt;
      property OnCompleted: TNotifyEvent read FOnCompleted write FOnCompleted;
  end;

function timeGetTime: DWord; stdcall; external 'winmm.dll' name 'timeGetTime';

procedure Register;

implementation

// THttpDownload methods follow
Constructor THttpDownload.Create(AOwner: TComponent);
  begin
    FHandle := AllocateHWnd(Window_Handler);
    inherited create(aowner);
  end;

function GetCurrFilePath: string;
  var
    filelen: integer;
  begin
    SetLength(Result, MAX_PATH);
    filelen := GetModuleFileName(0, PChar(Result), MAX_PATH);
    SetLength(Result, filelen);
    Result := ExtractFilePath(Result);
  end;

procedure THttpDownload.Loaded;
  { initializations of the control }
  begin
    inherited loaded;
    // enforce defaults
    if (csDesigning in ComponentState) then
    else
      begin
        if FSaveFilePath = '' then
          FSaveFilePath := GetCurrFilePath;
        if UserAgent = '' then
          UserAgent := 'Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 5.1; Trident/4.0)';
      end;
  end;

Destructor THttpDownload.Destroy;
  begin
    DeallocateHWnd(FHandle);
    Inherited;
  end;

procedure THttpDownload.Window_Handler(var msg: TMessage);
  begin
    case Msg.Msg of
      WM_WEBPROGRESS:
        begin
          if Assigned(FOnProgress) then
             FOnProgress(Self, Msg.WParam, DownloadSize)
        end;
      WM_WEBFILE:
        begin
          if Assigned(FOnFilePrompt) then
            begin
              FOnFilePrompt(Self, String(Pointer(Msg.WParam)^),
                                  String(Pointer(Msg.LParam)^));
            end;
        end;
      WM_WEBFINISHED:
        begin
          FDownloader.Free;
          if Assigned(FOnCompleted) then
            FOnCompleted(Self);
        end;
    else
      DefWindowProc(FHandle, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

procedure THttpDownload.DownloadCancel;
  begin
    FDownloader.Terminate;
  end;

procedure THttpDownload.DownloadPause;
  begin
    FDownloader.Suspend;
  end;

procedure THttpDownload.DownloadResume;
  begin
    FDownloader.Resume;
  end;

procedure THttpDownload.WaitForDownload;
  begin
    repeat
      Application.ProcessMessages;
    until WaitForSingleObject(FDownloader.Handle, 20) = WAIT_OBJECT_0;
  end;

procedure THttpDownload.DownloadFile;
  var
    test: DWord;
  begin
    FDownloader := TWebDownloader.Create(True);
    FDownloader.FreeOnTerminate := false;
    FDownloader.Priority := tpTimeCritical;

    FDownloader.URL := URL;
    FDownloader.SaveFilePath := FSaveFilePath;
    FDownloader.UserAgent := FUserAgent;
    FDownloader.UseDownloadRanges := FUseDownloadRanges;
    FDownloader.ResumeDownload := FResumeDownload;
    FDownloader.HighRange := FHighRange;
    FDownloader.LowRange := FLowRange;
    FDownloader.Win_Handle := FHandle;
    FDownloader.PropEvent := CreateEvent(nil, True, False, nil);
    FDownloader.Resume;
// probably need better way to do this so OnFilePrompt can fire in this
    // period, but can't think of good way without going to a lot of trouble.
    repeat
      test := WaitForSingleObject(FDownloader.PropEvent, 200);
      Application.ProcessMessages;
    until test = WAIT_OBJECT_0;
    DownloadSize := FDownloader.DownloadSize;
    URL := FDownloader.URL;
    StatusCode := FDownloader.StatusCode;
    StatusText := FDownloader.StatusText;
  end;

// **********************************************************************
// TWebDownloader methods follow
// **********************************************************************
function TWebDownloader.GetSaveFile(inURL: string): String;
// pulls the file name off the URL and removes all escape characters
  var
    UrlComp: URL_COMPONENTS;
    outpath: array[1..200] of WideChar;
    sz: string;
    i: integer;
  begin
    Result := '';
    FillChar(URLComp, Sizeof(Urlcomp), 0);
    Urlcomp.dwStructSize := Sizeof(URlComp);
    UrlComp.dwUrlPathLength := 400;
    UrlComp.lpszUrlPath := @outpath[1];
    if WinHttpCrackURL(PWideChar(WideString(inURL)), 0, ICU_DECODE, URLComp) then
      begin
        sz := String(outpath);
        SetLength(sz, UrlComp.dwURLPathLength);
        i := length(sz);
        while sz[i] <> '/' do dec(i);
        Result := copy(sz, i+1, 2000);
      end;
  end;

function TWebDownloader.GetContentLength(URLHandle: HINTERNET): Int64;
// returns the expected download size.  Returns -1 if one not provided
  var
    SBuffer: Array[1..20] of WideChar;
    sbufstring: string;
    SBufferSize: Integer;
  begin
    SBufferSize := 40;
    if WinHttpQueryHeaders(URLHandle, WINHTTP_QUERY_CONTENT_LENGTH,
      WINHTTP_HEADER_NAME_BY_INDEX, @SBuffer[1], SBufferSize,
      WINHTTP_NO_HEADER_INDEX) then
      begin
        sbufstring := WideString(Sbuffer);
        Result := StrToFloat(SBufString);
      end
    else
      Result := -1;
  end;

function TWebDownloader.GetFullURL(URLHandle: HINTERNET; fURL: string): String;
  // returns the real URL in case the given URL is a redirect.
  var
    sbuffer: Array[1..1000] of Widechar;
    sbuffersize: integer;
  begin
  // get real URL and save it back to fURL
    SBufferSize := 1000;
    WinHttpQueryOption(URLHandle, WINHTTP_OPTION_URL, @sbuffer[1], sbuffersize);
    Result := String(WideString(SBuffer));
    SetLength(Result, SBufferSize div 2);
  end;

function TWebDownloader.GetStatusText(URLHandle: HINTERNET): string;
  var
    sbuffersize: integer;
    sbuffer: array[1..1000] of WideChar;
  begin
    Sbuffersize := 1000;
    WinHttpQueryHeaders(URLHandle, WINHTTP_QUERY_STATUS_TEXT,
      WINHTTP_HEADER_NAME_BY_INDEX, @sbuffer[1], sbuffersize,
      WINHTTP_NO_HEADER_INDEX);
    Result := String(WideString(SBuffer));
    SetLength(Result, SbufferSize div 2);
  end;

function TWebDownloader.GetStatusCode(URLHandle: HINTERNET): integer;
  var
    sbuffersize: integer;
  begin
  // return status of transaction
    SBufferSize := Sizeof(Longint);
    WinHttpQueryHeaders(URLHandle,
       WINHTTP_QUERY_STATUS_CODE or WINHTTP_QUERY_FLAG_NUMBER,
       WINHTTP_HEADER_NAME_BY_INDEX, @Result, SBufferSize,
       WINHTTP_NO_HEADER_INDEX);
  end;

function TWebDownloader.getURLHost(inURL: string): string;
// returns the host part of a URL presented
  var
    s1, s2: integer;
  begin
    s1 := pos('//', inURL);
    s2 := s1+2;
    while inURL[s2] <> '/' do
      inc(s2);
    Result := copy(inURL, s1+2, s2-s1-2);
  end;

function TWebDownloader.getURLPath(inURL: string): String;
// returns the path part of a URL presented
  var
    s1: integer;
  begin
    s1 := pos('//', inURL);
    while inURL[s1+2] <> '/' do inc(s1);
    Result := copy(inURL, s1+2, 20000);
  end;

function TWebDownloader.GetRangeString: string;
  // returns a range string based on the low and high ranges inputted.
  var
    outrange: string;
  begin
  // check for stock errors in calling this function, given values are in design
    if not UseDownloadRanges then
      raise EInvalidOp.Create('Invalid function call for settings made.');
    if (HighRange = 0) and (LowRange = 0) then
      raise EInvalidOp.Create('Values must be specified for this function call.');
  // if HighRange not specified then specify lower range & exit
    if HighRange = 0 then
      outrange := 'Range: bytes=' + FloatToStr(LowRange) + '-'
    else
      outrange := 'Range: bytes=' + FloatToStr(LowRange) + '-' + FloatToStr(HighRange);
    Result := OutRange;
  end;

function TWebDownloader.FileSizeEx(savefile: string): Int64;
  // extended file size function.
  type
    QWord = packed record
      Low: DWord;
      High: DWord;
    end;
  var
    SizeOfFile: QWord;
    shandle: THandle;
  begin
    SHandle := CreateFile(PChar(SaveFile), GENERIC_READ or GENERIC_WRITE,
               FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    try
      SizeOfFile.Low := GetFileSize(shandle, @SizeOfFile.High);
      Result := Int64(SizeOfFile);
    finally
      CloseHandle(SHandle);
    end;
  end;

procedure TWebDownloader.CleanUp;
  begin
    if hSession <> nil then WinHttpCloseHandle(hSession);
    if hConnect <> nil then WinHttpCloseHandle(hConnect);
    if hRequest <> nil then WinHttpCloseHandle(hRequest);
    SendMessage(Self.Win_Handle, WM_WEBFINISHED, 0, 0);
  end;

procedure TWebDownloader.Execute;
  var
    dwContext: DWord;
    BytesRead, BytesWritten: dWord;
    SHandle: THandle;
    SaveFile: String;
    siteid, sitepath: string;
    rangestr: string;
    FTimer: DWord;

    ua: WideString;
  begin
    hConnect := nil;
    hRequest := nil;
    ua := UserAgent;
    hSession := WinHttpOpen(PWideChar(ua), WINHTTP_ACCESS_TYPE_DEFAULT_PROXY,
           WINHTTP_NO_PROXY_NAME, WINHTTP_NO_PROXY_BYPASS, 0);
    if Assigned(hSession) then
      begin
        siteid := getURLHost(URL);
        sitepath := getURLPath(URL);
        if hSession <> nil then
          hConnect := WinHttpConnect(hSession, PWideChar(WideString(siteid)), INTERNET_DEFAULT_HTTP_PORT, 0);
        if hConnect <> nil then
          hRequest :=  WinHttpOpenRequest( hConnect, 'GET', PWideChar(WideString(sitepath)), nil,
              WINHTTP_NO_REFERER, WINHTTP_DEFAULT_ACCEPT_TYPES, 0);
        if Assigned(hRequest) then
          begin
            // SaveFilePath needs a '\' on the end if it is not already there
            if SaveFilePath[Length(SaveFilePath)] <> '\' then
              SaveFilePath := SaveFilePath + '\';
          // if download resume, prompt for file now, and set download ranges
            if ResumeDownload then
              begin
                SendMessage(Self.Win_Handle, WM_WEBFILE,
                           Integer(@SaveFilePath), Integer(@LocalFName));
                if LocalFName = '' then
                  begin
                    CleanUp;
                    SetEvent(PropEvent);
                    exit;
                  end;
                SaveFile := SaveFilePath + LocalFName;
                UseDownloadRanges := true;
                LowRange := FileSizeEx(SaveFile);
                HighRange := 0;
              end;
          // this stuff to set range request header
          if UseDownloadRanges then
            begin
              rangestr := GetRangeString;
              WinHttpAddRequestHeaders(hRequest, PWideChar(WideString(rangestr)),
                     Length(rangestr), WINHTTP_ADDREQ_FLAG_ADD_IF_NEW);
            end;
          if not WinHttpSendRequest( hRequest, WINHTTP_NO_ADDITIONAL_HEADERS,
               0, WINHTTP_NO_REQUEST_DATA, 0, 0, dwContext) then
            begin
              StatusCode := GetLastError;
              StatusText := WinHttpSysErrorMessage(StatusCode);
              CleanUp;
              SetEvent(PropEvent);
              exit;
            end;
          if not WinHttpReceiveResponse(hRequest, nil) then
            begin
              StatusCode := GetLastError;
              StatusText := WinHttpSysErrorMessage(StatusCode);
              CleanUp;
              SetEvent(PropEvent);
              exit;
            end;
// all the service routines are here and results need written out
          URL := GetFullURL(hRequest, URL);
          DownloadSize := GetContentLength(hRequest);
          StatusText := GetStatusText(hRequest);
          StatusCode := GetStatusCode(hRequest);
          SetEvent(PropEvent);
          if not ResumeDownload then
            begin
              LocalFName := GetSaveFile(URL);
              SendMessage(Self.Win_Handle, WM_WEBFILE,
                            Integer(@SaveFilePath), Integer(@LocalFName));
              if LocalFName = '' then
                 begin
                   CleanUp;
                   exit;
                 end;
               SaveFile := SaveFilePath + LocalFName;
            end;
          FSizeRead := 0;
          FTimer := timeGetTime;
          if ResumeDownload then
            begin
              SHandle := CreateFile(PChar(SaveFile),
                      GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil,
                      OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
              SetFilePointer(SHandle, 0, nil, FILE_END);
            end
          else
            begin
              SHandle := CreateFile(PChar(SaveFile),
                      GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil,
                      CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
            end;
          FillChar(szBuffer, SizeOf(szBuffer), 0);
          if not WinHttpReadData(hRequest, @szbuffer, sizeof(szbuffer), BytesRead) then
            begin
              StatusCode := GetLastError;
              StatusText := WinHttpSysErrorMessage(StatusCode);
              CleanUp;
              CloseHandle(SHandle);
              exit;
            end;
          while (bytesread > 0) and (not Terminated) do
            begin
              WriteFile(SHandle, szBuffer, BytesRead, BytesWritten, nil);
              FSizeRead := FSizeRead + BytesRead;
              if (timeGetTime - FTimer) > 1000 then
                begin
                  PostMessage(Self.Win_Handle, WM_WEBPROGRESS, FSizeRead, 0);
    //            SendMessage(Self.Win_Handle, WM_WEBPROGRESS, FSizeRead, 0);
                  FSizeRead := 0;
                  FTimer := timeGetTime;
                end;
              FillChar(szBuffer, SizeOf(szBuffer), 0);
              if not WinHttpReadData(hRequest, @szbuffer, sizeof(szbuffer), BytesRead) then
                begin
                  StatusCode := GetLastError;
                  StatusText := WinHttpSysErrorMessage(StatusCode);
                  CleanUp;
                  CloseHandle(SHandle);
                  exit;
                end;
            end;
          SendMessage(Self.Win_Handle, WM_WEBPROGRESS, FSizeRead, 0);
          CloseHandle(SHandle);
          if hConnect <> nil then WinHttpCloseHandle(hConnect);
          if hRequest <> nil then WinHttpCloseHandle(hRequest);
        end
      else
        raise Exception.CreateFmt('Cannot open URL %s', [Url]);
      if hSession <> nil then WinHttpCloseHandle(hSession);
    end
  else
    { NetHandle is not valid. Raise an exception }
    raise Exception.Create('Unable to initialize Winhttp');
  PostMessage(Self.Win_Handle, WM_WEBFINISHED, 0, 0);
end;


procedure Register;
begin
  RegisterComponents('Samples', [THttpDownload]);
end;


end.