Does native Delphi HTTPClient support SNI? - http

We have to include SNI (Server_Name_Indication) in our rest requests because the server will hosts several virtual domains in the near future. We are using a standard THTTPClient component created at runtime.
As soon as we add a new domain with new certificate we receive an exception
"Server certificate invalid or does not exist"
(translated from the german error text)
Is there a special header value to archive SNI this like for the basic authentication?
Below is a simplified version of our code (no logging, no proxy, fake URL). I apologize that I can not provide the real URL we are using.
We would expect that we must augment the GetRequest method, but did not find any example or hint.
unit Unit1;
interface
uses
Winapi.Windows, WinApi.WinHTTP, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
System.Net.HTTPClient;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
private
function PostRequest(const cRequest, cBody: string): string;
public
{ Public declarations }
end;
type
TMyRestClient = class(TObject)
private
fHTTPClient: THTTPClient;
fSysUrl: string;
fUserID: string;
fPassWD: string;
//...
function GetRequest(const cMethod, cUrl: string): IHTTPRequest;
public
constructor Create(const cUrl: string);
destructor Destroy; override;
function Post(const cRequest, cBody: string): string;
//...
property SystemUrl: string read fSysUrl write fSysUrl;
property Username: string read fUserID write fUserID;
property Password: string read fPassWD write fPassWD ;
end;
var
Form1: TForm1;
implementation
uses
System.SysUtils, System.Variants, System.NetEncoding;
{$R *.dfm}
constructor TMyRestClient.Create(const cUrl: string);
begin
fHTTPClient := THTTPClient.Create;
SystemUrl := cUrl;
end;
destructor TMyRestClient.Destroy;
begin
FreeAndNil(fHTTPClient);
inherited Destroy;
end;
function TMyRestClient.GetRequest(const cMethod, cUrl: string): IHTTPRequest;
begin
Result := fHTTPClient.GetRequest(cMethod, cUrl);
Result.AddHeader('content-type', 'appplication/json');
if (Password <> '') then
Result.AddHeader('Authorization', 'Basic ' + TNetEncoding.Base64.Encode(Username + ':' + Password));
end;
function TMyRestClient.Post(const cRequest, cBody: string): string;
var
iRequest: IHTTPRequest;
iResponse: IHTTPResponse;
aBody: TStringStream;
begin
iRequest := GetRequest('POST', Format('%s/%s', [SystemUrl, cRequest]));
aBody := TStringStream.Create(UTF8String(cBody));
try
iRequest.SourceStream := aBody;
iResponse := fHTTPClient.Execute(iRequest);
finally
aBody.DisposeOf;
end;
if (iResponse.StatusCode <> HTTP_STATUS_OK) then
raise Exception.CreateFmt('Post: %s failed (Code %d) %', [cRequest, iResponse.StatusCode, iResponse.StatusText]);
Result := iResponse.ContentAsString;
end;
function TForm1.PostRequest(const cRequest, cBody: string): string;
var
xClient: TMyRestClient;
begin
xClient := TMyRestClient.Create('www.myserver.com/demo');
try
// Basic authentification (not used)
xClient.Username := '';
xClient.Password := '';
Result := xClient.Post(cRequest, cBody);
finally
xClient.DisposeOf
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := PostRequest('retrieve/paramvalue', '{''PARAM'':''VERSION''}' );
end;

Related

TNetHTTPClient OnRequestError does not trigger

I must be overlooking something....
Why doesn't the NetHTTPClientRequestError get triggered here?
type
TUpdateChecker = class
private
var FHTTP : TNetHTTPClient;
var FAbort : Boolean;
procedure NetHTTPClientRequestError(const Sender: TObject; const AError: string);
public
constructor Create;
destructor Destroy; override;
function CheckNewVersion(var ANewVer: String): Boolean;
end;
{ TUpdateChecker }
constructor TUpdateChecker.Create;
begin
inherited;
FHTTP := TNetHTTPClient.Create(nil);
FHTTP.OnRequestError := NetHTTPClientRequestError; // Error handler assigned here
FHTTP.ConnectionTimeOut := 10000;
end;
destructor TUpdateChecker.Destroy;
begin
FHTTP.Free;
inherited;
end;
function TUpdateChecker.CheckNewVersion(var ANewVer: String): Boolean;
var
lJSONStr: String;
begin
Result := false;
try
lJSONStr := FHTTP.Get(cUpdateJSON + 'sdhgfy').ContentAsString; // Add some junk to cause error
except
on E:Exception do
begin
// We don't get at the breakpoint here
WriteErrorLog(TSettings.DataLocation + cErrLogFile, 'CheckNewVersion: ' + E.Message);
Exit;
end;
end;
if FAbort then Exit; // FABort = false here
// Rest of code removed
end;
procedure TUpdateChecker.NetHTTPClientRequestError(const Sender: TObject; const AError: string);
begin
// We don't get at the breakpoint here, FAbort never becomes true
ShowMessage('ERROR Sender.ClassName=' + Sender.ClassName + ' AError=' + AError);
FAbort := true;
end;
Calling code from a FormShow:
lCheck := TUpdateChecker.Create;
try
if lCheck.CheckNewVersion(lNewVer) then
begin
LblNewVersion.Caption := Format(LblNewVersion.Caption,[lNewVer]);
LblNewVersion.Visible := true;
LblUpgrade.Visible := true;
end;
finally
lCheck.Free;
end;
This is a Win32 app running on Win10.
cUpdateJSON is a valid URL to a JSON file on my website. I added the 'sdhgfy' junk to cause the error. My attention is to catch both 'common' HTTP status code like 500, 404, as well as exceptions.
Because :
lJSONStr := FHTTP.Get(cUpdateJSON + 'sdhgfy').ContentAsString;
is executing successfully.
Whatever cUpdateJSON is, it points to a valid server that is returning data to you, even though you have appended some garbage. It won't be the data you expect, but it will be data nevertheless, so the error is not raised.
You will need to validate the returned data to be sure that the server returned what you expected. NetHTTPClientRequestError will only handle cases where the URL specified fails to connect, etc (transport, socket, and protocol level exceptions). It knows nothing about whether or not the service on the other end was able to handle your specific request or not. It delivered your request successfully and the server returned a response. That's all it cares about.
If you want to check the server response you can inspect the StatusCode from the returned IHTTPResponse before saving its content into a string:
function TUpdateChecker.CheckNewVersion(var ANewVer: String): Boolean;
const
HTTP_OK = 200;
var
lResp : IHTTPResponse;
lJSONStr: String;
begin
Result := false;
try
lResp := FHTTP.Get('http://www.google.com/thiswontwork');
// Note by OP: *if* the NetHTTPClientRequestError gets triggered
// we have serious errors like e.g. invalid certificates
// and lResp.StatusCode will give an AV. Therefore:
if FAbort then Exit;
if lResp.StatusCode <> HTTP_OK then begin
// handle me!
end else
lJSONStr := lResp.ContentAsString();
except
on E:Exception do
begin
WriteErrorLog(TSettings.DataLocation + cErrLogFile,
'CheckNewVersion: ' + E.Message);
Exit;
end;
end;
if FAbort then Exit; // FABort = false here
// Rest of code removed
end;

Delphi TDictionary with generics

I need a container with different TProc indexed by String.
Something like TDictionary.
TMessageBus = class
private
fContainer: TDictionary<String, TProc<T>>; // ERROR !!
public
procedure Send<T>(aName: String; aData: T); // producer
procedure Subscribe<T>(aName: String; aProc: TProc<T>); // consumer
end;
Please help.
If you have a field dependent on the generic type T you have to make the complete class generic and not the methods:
type
TMessageBus<T> = class
private
fContainer: TDictionary<String, TProc<T>>; // ERROR !!
public
procedure Send(aName: String; aData: T); // producer
procedure Subscribe(aName: String; aProc: TProc<T>); // consumer
end;
Knowing that TProc<T> is implemented as interface you can write this code:
type
TMessageBus = class
private
fContainer: TDictionary<string, IInterface>;
public
constructor Create;
destructor Destroy; override;
procedure Send<T>(const aName: string; const aData: T);
procedure Subscribe<T>(const aName: string; const aProc: TProc<T>);
end;
constructor TMessageBus.Create;
begin
fContainer := TDictionary<string, IInterface>.Create;
end;
destructor TMessageBus.Destroy;
begin
fContainer.Free;
inherited;
end;
procedure TMessageBus.Send<T>(const aName: string; const aData: T);
begin
TProc<T>(fContainer[aName])(aData);
end;
procedure TMessageBus.Subscribe<T>(const aName: string; const aProc: TProc<T>);
begin
fContainer.AddOrSetValue(aName, IInterface(PPointer(#aProc)^));
end;
However apart from leaving out any validation code this can easily blow up if you do send a different data type than you subscribed. So I would use the TValue type here to wrap the passed TProc<T> inside a TProc<TValue> (from System.Rtti). Keep in mind however that TValue itself only allows type conversions that also the compiler allows, so it won't convert string to Integer and alike - but if required you can then add this yourself:
type
TMessageBus = class
private
fContainer: TDictionary<string, TProc<TValue>>;
public
constructor Create;
destructor Destroy; override;
procedure Send<T>(const aName: string; const aData: T);
procedure Subscribe<T>(const aName: string; const aProc: TProc<T>);
end;
constructor TMessageBus.Create;
begin
fContainer := TDictionary<string, TProc<TValue>>.Create;
end;
destructor TMessageBus.Destroy;
begin
fContainer.Free;
inherited;
end;
procedure TMessageBus.Send<T>(const aName: string; const aData: T);
var
proc: TProc<TValue>;
begin
if fContainer.TryGetValue(aName, proc) then
proc(TValue.From<T>(aData));
end;
procedure TMessageBus.Subscribe<T>(const aName: string; const aProc: TProc<T>);
begin
fContainer.AddOrSetValue(aName,
procedure(aValue: TValue)
begin
aProc(aValue.AsType<T>);
end);
end;
If you now call mb.Send('somestring', 42); for example it will raise an EInvalidCast exception in TValue.AsType because as mentioned before it can't convert the passed 42 to string which is what you specified when you called Subscribe.

Delphi Indy CookieManager Wordpress Login

The problem is that when I press the login button I get this in the memo: "Your session has expired. You can log in again from this page or go to the login page". I'm using XE3. Thanks for your help
var
tslPost1: TStringList;
sResult1: String;
idhHttp1: TIdHTTP;
procedure TForm1.Button1Click(Sender: TObject);
begin
tslPost1 := TStringList.Create;
idhHttp1 := TIdHTTP.Create;
idhHttp1.HandleRedirects := True;
idhHttp1.AllowCookies := True;
idHttp1.CookieManager := Form1.IdCookieManager1;
idhHttp1.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:12.0) Gecko/20100101 Firefox/12.0';
try
tslPost1.Add('log=' + Edit1.Text);
tslPost1.Add('pwd=' + Edit2.Text);
tslPost1.Add('rememberme=forever');
tslPost1.Add('wp-submit=Login');
tslPost1.Add('redirect_to=' + Edit3.Text + '/wp-admin/');
tslPost1.Add('testcookie=1');
idhHttp1.Get(Edit3.Text + '/wp-login.php');
idhHttp1.Post(Edit3.Text + '/wp-login.php', tslPost1);
sResult1 := idhHttp1.Get(Edit3.Text + '/wp-admin/');
Memo1.Lines.Add(sResult1);
finally
FreeAndNil(tslPost1);
FreeAndNil(idhHttp1);
end;
end;
pls try adding the cookie manually:
CookieManager.AddServerCookie('wordpress_test_cookie=WP+Cookie+check',
TIdURI.Create(Website));
or a complete login function:
function TWordPress.Login(AIdHTTPHelper: TIdHTTPHelper): Boolean;
var
Params: TStringList;
Enc: TEncoding;
ResponseStr: string;
begin
Result := False;
with AIdHTTPHelper do
begin
AddCookie('wordpress_test_cookie=WP+Cookie+check', Website);
Params := TStringList.Create;
try
with Params do
begin
Add('log=' + AccountName);
Add('pwd=' + AccountPassword);
Add('rememberme=forever');
Add('wp-submit=');
Add('testcookie=1');
end;
Request.CharSet := 'UTF-8';
Enc := CharsetToEncoding(Request.CharSet);
try
try
ResponseStr := Post(Website + 'wp-login.php', Params, Enc);
except
on E: Exception do
begin
ErrorMsg := E.message;
Exit;
end;
end;
finally
Enc.Free;
end;
finally
Params.Free;
end;
if (Pos('action=logout', ResponseStr) = 0) then
begin
with TRegExpr.Create do
begin
try
InputString := ResponseStr;
Expression := 'error">(.*?)<\/div>';
if Exec(InputString) then
begin
Self.ErrorMsg := HTML2Text(Match[1]);
Exit;
end;
finally
Free;
end;
end;
end;
end;
Result := True;
end;
here is my uIdHTTPHelper unit.
unit uIdHTTPHelper;
interface
uses
// Delphi
SysUtils, Classes, Dialogs, StrUtils,
// Indy
IdGlobal, IdURI, IdCharsets, IdHTTP, IdCookieManager, IdCookie, IdZLib, IdCompressorZLib, IdSSLOpenSSL, IdSocks, IdMultipartFormData,
// Plugin System
uPlugInInterface, uPlugInConst;
type
TIdHTTPHelper = class(TIdHTTP)
private
FLastRedirect: string;
function GetCookieList: string;
procedure SetCookieList(ACookies: string);
function GetResponseRefresh: string;
procedure Redirect(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod);
protected
FIdCookieManager: TIdCookieManager;
FIdCompressorZLib: TIdCompressorZLib;
FIdSSLIOHandlerSocketOpenSSL: TIdSSLIOHandlerSocketOpenSSL;
FIdSocksInfo: TIdSocksInfo;
public
constructor Create; overload;
constructor Create(const APlugIn: IPlugIn); overload;
property LastRedirect: string read FLastRedirect;
procedure AddCookie(ACookie, AWebsite: string);
procedure Get(AURL: string; AResponseContent: TStream); overload;
function Post(AURL: string; ASource: TStrings; AByteEncoding: TIdTextEncoding = nil): string; overload;
procedure Post(AURL: string; ASource, AResponseContent: TStream); overload;
procedure Post(AURL: string; ASource: TIdMultiPartFormDataStream; AResponseContent: TStream); overload;
property CookieList: string read GetCookieList write SetCookieList;
property Response_Refresh: string read GetResponseRefresh;
class function Charsets: string;
destructor Destroy; override;
end;
implementation
function TIdHTTPHelper.GetCookieList: string;
var
I: Integer;
begin
with TStringList.Create do
try
for I := 0 to CookieManager.CookieCollection.Count - 1 do
Add(CookieManager.CookieCollection.Cookies[I].ServerCookie);
Result := Text;
finally
Free;
end;
end;
procedure TIdHTTPHelper.SetCookieList(ACookies: string);
function ExtractUrl(const AURL: string): string;
var
I: Integer;
begin
I := PosEx('/', AURL, Pos('://', AURL) + 3);
if I > 0 then
Result := copy(AURL, 1, I)
else
Result := AURL;
end;
var
I: Integer;
begin
with TStringList.Create do
try
Text := ACookies;
for I := 0 to Count - 1 do
AddCookie(Strings[I], ExtractUrl(Request.Referer));
finally
Free;
end;
end;
function TIdHTTPHelper.GetResponseRefresh: string;
// Ähnlich dem "Location" Header
const
url = 'url=';
var
_RefreshHeader: string;
begin
_RefreshHeader := LowerCase(Response.RawHeaders.Values['Refresh']);
Result := '';
if (Pos(url, _RefreshHeader) > 0) then
Result := copy(_RefreshHeader, Pos(url, _RefreshHeader) + length(url));
end;
procedure TIdHTTPHelper.Redirect(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod);
begin
FLastRedirect := dest;
end;
constructor TIdHTTPHelper.Create();
begin
inherited Create(nil);
FIdCookieManager := TIdCookieManager.Create(nil);
FIdCompressorZLib := TIdCompressorZLib.Create(nil);
FIdSSLIOHandlerSocketOpenSSL := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
FIdSocksInfo := TIdSocksInfo.Create(nil);
OnRedirect := Redirect;
end;
constructor TIdHTTPHelper.Create(const APlugIn: IPlugIn);
var
_ICMSPlugin: ICMSPlugIn;
begin
Create();
with APlugIn do
if Proxy.Active then
if not(Proxy.ServerType = ptHTTP) then
with FIdSocksInfo do
begin
Host := Proxy.Server;
Port := Proxy.Port;
if (Proxy.ServerType = ptSOCKS4) then
Version := svSocks4
else
Version := svSocks5;
Username := Proxy.AccountName;
Password := Proxy.AccountPassword;
Enabled := True;
end
else
with ProxyParams do
begin
ProxyServer := Proxy.Server;
ProxyPort := Proxy.Port;
ProxyUsername := Proxy.AccountName;
ProxyPassword := Proxy.AccountPassword;
end;
FIdSSLIOHandlerSocketOpenSSL.TransparentProxy := FIdSocksInfo;
CookieManager := FIdCookieManager;
Compressor := FIdCompressorZLib;
IOHandler := FIdSSLIOHandlerSocketOpenSSL;
AllowCookies := True;
HandleRedirects := True;
ConnectTimeout := APlugIn.ConnectTimeout;
ReadTimeout := APlugIn.ReadTimeout;
ProtocolVersion := pv1_1;
HTTPOptions := HTTPOptions + [hoKeepOrigProtocol];
Request.Accept := 'text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1';
Request.AcceptCharSet := 'iso-8859-1, utf-8, utf-16, *;q=0.1';
Request.AcceptEncoding := 'deflate, gzip, identity, *;q=0';
Request.AcceptLanguage := 'de-DE,de;q=0.9,en;q=0.8';
Request.Connection := 'Keep-Alive';
Request.ContentType := 'application/x-www-form-urlencoded';
if Supports(APlugIn, ICMSPlugIn) then
begin
if APlugIn.QueryInterface(ICMSPlugIn, _ICMSPlugin) = 0 then
try
Request.Referer := _ICMSPlugin.Website;
finally
_ICMSPlugin := nil;
end;
end;
Request.UserAgent := 'Opera/9.80 (Windows NT 6.1; U; de) Presto/2.9.168 Version/11.51';
ReuseSocket := rsTrue;
end;
procedure TIdHTTPHelper.AddCookie(ACookie: string; AWebsite: string);
var
IdURI: TIdURI;
begin
IdURI := TIdURI.Create(AWebsite);
try
CookieManager.AddServerCookie(ACookie, IdURI);
finally
IdURI.Free;
end;
end;
procedure TIdHTTPHelper.Get(AURL: string; AResponseContent: TStream);
begin
try
inherited Get(AURL, AResponseContent);
except
on E: EDecompressionError do
;
on E: EIdHTTPProtocolException do
begin
if not(Pos('<body', LowerCase(E.ErrorMessage)) = 0) then
begin
if AResponseContent.InheritsFrom(TStringStream) then
TStringStream(AResponseContent).WriteString(E.ErrorMessage);
end
else
raise ;
end;
end;
end;
function TIdHTTPHelper.Post(AURL: string; ASource: TStrings; AByteEncoding: TIdTextEncoding = nil): string;
begin
try
Result := inherited Post(AURL, ASource, AByteEncoding);
except
on E: EDecompressionError do
;
on E: EIdHTTPProtocolException do
begin
if not(Pos('<body', LowerCase(E.ErrorMessage)) = 0) then
Result := E.ErrorMessage
else
raise ;
end;
end;
if SameStr('', Result) then
begin
if not(Response.Location = '') then
Result := Get(Response.Location)
else if not(Response_Refresh = '') then
Result := Get(Response_Refresh);
end;
end;
procedure TIdHTTPHelper.Post(AURL: string; ASource, AResponseContent: TStream);
begin
try
inherited Post(AURL, ASource, AResponseContent);
except
on E: EDecompressionError do
;
on E: EIdHTTPProtocolException do
begin
if not(Pos('<body', LowerCase(E.ErrorMessage)) = 0) then
begin
if AResponseContent.InheritsFrom(TStringStream) then
TStringStream(AResponseContent).WriteString(E.ErrorMessage);
end
else
raise ;
end;
end;
if AResponseContent.InheritsFrom(TStringStream) and (TStringStream(AResponseContent).DataString = '') then
begin
if not(Response.Location = '') then
Get(Response.Location, AResponseContent)
else if not(Response_Refresh = '') then
Get(Response_Refresh, AResponseContent);
end;
end;
procedure TIdHTTPHelper.Post(AURL: string; ASource: TIdMultiPartFormDataStream; AResponseContent: TStream);
begin
Assert(ASource <> nil);
Request.ContentType := ASource.RequestContentType;
Post(AURL, TStream(ASource), AResponseContent);
end;
class function TIdHTTPHelper.Charsets: string;
var
Lcset: TIdCharset;
begin
with TStringList.Create do
try
for Lcset := TIdCharset(1) to high(TIdCharset) do
Add(IdCharsetNames[Lcset]);
Result := Text;
finally
Free;
end;
end;
destructor TIdHTTPHelper.Destroy;
begin
FIdSocksInfo.Free;
FIdSSLIOHandlerSocketOpenSSL.Free;
FIdCompressorZLib.Free;
FIdCookieManager.Free;
inherited Destroy;
end;
end.

Returning a limited type in Ada

I am trying to return a limited type via a constructor function. I understand that because it is a limited type, I cannot copy the type but I am not sure of the best way to do it. I have it working using an extended return statement but I have been told that I should be able to return a limited type without it.
thing_protected.ads:
package Thing_Protected is
type Thing is protected interface;
procedure Verb_It (Object : in out Thing; Key : String) is abstract;
function Create return Thing'Class;
private
protected type Thing_Impl is new Thing with
overriding procedure Verb_It (Key : String);
private
Data : Integer;
end Thing_Impl;
end Thing_Protected;
thing_protected.adb:
package body Thing_Protected is
function Create return Thing'Class is
begin
-- Not sure how to make this work:
-- return Thing_Impl'(Data=><>, others=><>);
-- thing_protected.adb:6:35: expected type "Thing_Impl" defined at thing_protected.ads:10
-- thing_protected.adb:6:35: found a composite type
-- extended return:
-- return X : Thing_Impl do
-- null;
-- end return;
-- shortened version:
return X : Thing_Impl;
end;
protected body Thing_Impl is
overriding procedure Verb_It (Key : String) is
begin
null;
end;
end Thing_Impl;
end Thing_Protected;
main.adb:
with Thing_Protected;
procedure Main is
Thing_Instance : Thing_Protected.Thing'Class := Thing_Protected.Create;
begin
null;
end;
Hm, so you want to initialize Data? You could use generics/packages to do that... it's a little long and perhaps a little convoluted.
package Thing_Protected is
type Thing is protected interface;
procedure Verb_It (Object : in out Thing; Key : String) is abstract;
function Create return Thing'Class;
private
generic
Default : in Integer;
package Implementation is
protected type Thing_Impl is new Thing with
procedure Verb_It (Key : String);
private
Data : Integer:= Default;
end Thing_Impl;
Function Create return Thing'Class;
end Implementation;
end Thing_Protected;
package body Thing_Protected is
package body Implementation is
protected body Thing_Impl is
overriding procedure Verb_It (Key : String) is
begin
null;
end;
end Thing_Impl;
function Create return Thing'class is
begin
return Result : Thing_Impl do
null;
end return;
end Create;
end Implementation;
function K( Data_Val : Integer := 10 ) return Thing'Class is
Package I is new Implementation( Default => Data_Val );
begin
return X : Thing'Class := I.Create do
null;
end return;
end K;
function Create return Thing'Class is ( K );
end Thing_Protected;

Delphi - Download a File with Progress using Synapse

I have been using Synapse for some time now, to send e-mails mainly. Today I am creating a simple installer, and trying to download the application exe file through HTTP. The file is about 9 MB in size, so I´d like to add a progress status to user, but I do not understand the examples I found. Here is what I got so far:
type
THookSocketStatus = Procedure(Sender: TObject; Reason: THookSocketReason; const Value: String) of Object;
CallBack = class
Class Procedure Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
end;
Class Procedure CallBack.Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
var
V: String;
Begin
V := GetEnumName(TypeInfo(THookSocketReason), Integer(Reason)) + ' ' + Value;
Form1.mem1.Lines.Add(V);
application.ProcessMessages;
end;
procedure TForm1.btn1Click(Sender: TObject);
var
HTTP: THTTPSend;
MSTM: TMemoryStream;
begin
Screen.Cursor := crHourGlass;
HTTP := THTTPSend.Create;
MSTM := TMemoryStream.Create;
Try
Try
HTTP.Sock.OnStatus := CallBack.Status;
If HTTP.HTTPMethod('GET', edt1.Text) Then
Begin
MSTM.Seek(0, soFromBeginning);
MSTM.CopyFrom(HTTP.Document, 0);
MSTM.SaveToFile(ExtractFilePath(Application.ExeName) + 'test.exe');
end;
Except
end;
Finally
MSTM.Free;
HTTP.Free;
Screen.Cursor := crDefault;
end;
end;
In this simple test I got this result:
HR_SocketClose
HR_ResolvingBegin www.website.com:80
HR_ResolvingEnd 176.102.295.18:80
HR_SocketCreate IPv4
HR_Connect www.website.com:80
HR_WriteCount 158
HR_CanRead
HR_ReadCount 288
HR_CanRead
HR_ReadCount 8192
HR_ReadCount 8192
HR_ReadCount 8192
HR_ReadCount 6720
HR_CanRead
HR_ReadCount 3299
.
.
.
HR_ReadCount 8192
HR_ReadCount 8192
HR_ReadCount 7828
HR_SocketClose
HR_SocketClose
Please, what means WriteCount and ReadCount? How can I get total file size to set the progress bar before start the download?
Thank you guys!
I had the same problem and found a solution by extending the code above. The file length was available as suggested above by using the Header information.
Here is my code:
unit uhttpdownloader;
{$mode Delphi}{$H+}
interface
uses
Classes, SysUtils, httpsend, blcksock, typinfo;
//Interface for notifications about the progress
type
IProgress = interface
procedure ProgressNotification(Text: String; CurrentProgress : integer; MaxProgress : integer);
end;
type
{ THttpDownloader }
THttpDownloader = class
public
function DownloadHTTP(URL, TargetFile: string; ProgressMonitor : IProgress): Boolean;
private
Bytes : Integer;
MaxBytes : Integer;
HTTPSender: THTTPSend;
ProgressMonitor : IProgress;
procedure Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
function GetSizeFromHeader(Header: String):integer;
end;
implementation
function THttpDownloader.DownloadHTTP(URL, TargetFile: string; ProgressMonitor : IProgress): Boolean;
var
HTTPGetResult: Boolean;
begin
Result := False;
Bytes:= 0;
MaxBytes:= -1;
Self.ProgressMonitor:= ProgressMonitor;
HTTPSender := THTTPSend.Create;
try
//add callback function for status updates
HTTPSender.Sock.OnStatus:= Status;
HTTPGetResult := HTTPSender.HTTPMethod('GET', URL);
if (HTTPSender.ResultCode >= 100) and (HTTPSender.ResultCode<=299) then begin
HTTPSender.Document.SaveToFile(TargetFile);
Result := True;
end;
finally
HTTPSender.Free;
end;
end;
//Callback function for status events
procedure THttpDownloader.Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
var
V, currentHeader: String;
i: integer;
begin
//try to get filesize from headers
if (MaxBytes = -1) then
begin
for i:= 0 to HTTPSender.Headers.Count - 1 do
begin
currentHeader:= HTTPSender.Headers[i];
MaxBytes:= GetSizeFromHeader(currentHeader);
if MaxBytes <> -1 then break;
end;
end;
V := GetEnumName(TypeInfo(THookSocketReason), Integer(Reason)) + ' ' + Value;
//HR_ReadCount contains the number of bytes since the last event
if Reason = THookSocketReason.HR_ReadCount then
begin
Bytes:= Bytes + StrToInt(Value);
ProgressMonitor.ProgressNotification(V, Bytes, MaxBytes);
end;
end;
function THttpDownloader.GetSizeFromHeader(Header: String): integer;
var
item : TStringList;
begin
//the download size is contained in the header (e.g.: Content-Length: 3737722)
Result:= -1;
if Pos('Content-Length:', Header) <> 0 then
begin
item:= TStringList.Create();
item.Delimiter:= ':';
item.StrictDelimiter:=true;
item.DelimitedText:=Header;
if item.Count = 2 then
begin
Result:= StrToInt(Trim(item[1]));
end;
end;
end;
end.
The complete source code and example can be downloaded here as well:
http://andydunkel.net/lazarus/delphi/2015/09/09/lazarus_synapse_progress.html
Andy

Resources