Zagwostka na etapie tworzenia komponentu do pobierania pliku po HTTPS.

Odpowiedz Nowy wątek
2019-05-22 05:22
0

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.

edytowany 5x, ostatnio: olesio, 2019-05-22 17:09

Pozostało 580 znaków

2019-05-30 20:50
0

No ale teraz to naprawdę przeginacie... to nie ma totalnie żadnego znaczenia, czy to string, czy String. Jak dzieci w piaskownicy "a mój tata kupił większy telewizor", "nieprawda, bo my mamy lepszy" :P


That game of life is hard to play
I'm gonna lose it anyway
The losing card I'll someday lay
So this is all I have to say

Pozostało 580 znaków

2019-05-30 21:18
0

Formatowanie kodu nie jest rzeczą nieważną, bo wpływa na łatwość utrzymania oprogramowania.

Sama wielkość pierwszej literki jednego z wbudowanych typów danych większej szkody nie robi, jednak od takich rzeczy się zaczyna. Po jakimś czasie produkuje się syf a nie kod, którego nawet sam autor nie rozumie po tygodniu od jego napisania, a jego użytkownicy rwą włosy z głowy podczas analizy takich wspaniałości.


edytowany 4x, ostatnio: furious programming, 2019-05-30 21:19
co do zasady się zgadzam, ale walka na kilka (bardzo rozbudowanych, z obrazkami) wpisów o wielkość pierwszej litery to już lekka paranoja :P - cerrato 2019-05-30 21:39
Programiści to dziwni ludzie. :D - furious programming 2019-05-30 21:43
A ci od Pascala w szczególności ;) - cerrato 2019-05-30 21:45

Pozostało 580 znaków

Odpowiedz
Liczba odpowiedzi na stronę

1 użytkowników online, w tym zalogowanych: 0, gości: 1, botów: 0