There was a problem with the passage of authorization on the site https://www.google.com for receiving data.
I use synapse HTTPSend. Connection I do as follows:
procedure TForm1.Button2Click(Sender: TObject);
var httpsend: httpsend;
begin httpsend := Thttpsend.Create;
httpsend.Sock.CreateWithSSL(TSSLOpenSSL);
httpsend.Sock.SSLDoConnect;
httpsend.HTTPMethod('GET', 'https://www.google.com');
Memo1.Lines.LoadFromStream(httpsend.Document);
Memo1.Lines.Add(httpsend.ResultCode.ToString);
end;
Related
I write a basic Delphi MS-Windows service.
I install it with the /install directove. This works.
In the Windows Services list it exists.
I START it from there. Windows says it started successfully. It shows as running.
But nothing is executed, except the OnCreate and OnDestroy.
It is in fact NOT running, while Windows claims it IS running.
I tried Delpi 10.2 and the latest 10.4.
What is going wrong here? It is the most basic Service possible.
The Log output looks like this:
Create
AfterInstall
Destroy
Create
Destroy
Create
Destroy
program BartServiceTwo;
uses
Vcl.SvcMgr,
Unit1 in 'Unit1.pas' {BartService: TService};
{$R *.RES}
begin
// Windows 2003 Server requires StartServiceCtrlDispatcher to be
// called before CoRegisterClassObject, which can be called indirectly
// by Application.Initialize. TServiceApplication.DelayInitialize allows
// Application.Initialize to be called from TService.Main (after
// StartServiceCtrlDispatcher has been called).
//
// Delayed initialization of the Application object may affect
// events which then occur prior to initialization, such as
// TService.OnCreate. It is only recommended if the ServiceApplication
// registers a class object with OLE and is intended for use with
// Windows 2003 Server.
//
// Application.DelayInitialize := True;
//
if not Application.DelayInitialize or Application.Installing then
Application.Initialize;
Application.CreateForm(TBartService, BartService);
Application.Run;
end.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.SvcMgr;
type
TBartService = class(TService)
procedure ServiceExecute(Sender: TService);
procedure ServiceCreate(Sender: TObject);
procedure ServiceDestroy(Sender: TObject);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
procedure ServiceAfterInstall(Sender: TService);
private
{ Private declarations }
public
function GetServiceController: TServiceController; override;
procedure Log(Line:string);
{ Public declarations }
end;
var
BartService: TBartService;
LogFile: text;
Logfilename: string;
implementation
{$R *.dfm}
procedure TBartService.Log(Line:string);
begin
if Logfilename = '' then
begin
Logfilename := 'Log.txt';
Assignfile(LogFile,Logfilename);
end;
try
if FileExists(Logfilename)
then append(LogFile)
else rewrite(LogFile);
writeln(LogFile,line);
Closefile(LogFile);
except
on E:Exception do;
end;
end;
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
BartService.Controller(CtrlCode);
end;
function TBartService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TBartService.ServiceAfterInstall(Sender: TService);
begin
Log('AfterInstall');
end;
procedure TBartService.ServiceCreate(Sender: TObject);
begin
Log('Create');
messagebeep(0);
end;
procedure TBartService.ServiceDestroy(Sender: TObject);
begin
Log('Destroy');
end;
procedure TBartService.ServiceExecute(Sender: TService);
begin
Log('ServiceExecute Start. Terminated='+Terminated.ToString(true));
while not Terminated do
begin
try
ServiceThread.ProcessRequests(false);
Log('ServiceExecute');
// messagebeep(0);
sleep(1000);
except
on E:Exception do
begin
Log('ERROR: ServiceExecute: Final: '+E.Message);
end;
end;
end;
Log('ServiceExecute Out of loop.');
end;
procedure TBartService.ServiceStart(Sender: TService; var Started: Boolean);
begin
Log('ServiceStart');
end;
procedure TBartService.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
Log('ServiceStop');
end;
end.
I assume that during your debugging you have copy and pasted code into the unit from another project but you have not 'hooked up' the events properly. Bring up the project in Delphi and open the service module. Click on the Events tab in the Object Inspector and my guess is that they are all blank. (View the source of the .dfm and there is likely no OnExecute, OnStop, OnStop, etc events defined)
For example - double click the OnExecute event and I assume the IDE will automatically create a new OnExecute event rather than navigating to your OnExecute event in the unit.
Simply rehook up your events and it will most likely work as expected.
Solved. After using the 'LogMessage() system, I found that the service is in fact running.
But what happened, is that the destination folder of my simple Log file was transfered from the local executable directory to C:\Windows\System32\ and there was all the rest of the Log data... I never expected that :(
Thanks for all help, Bart
I have an application written in Delphi 10.1 using REST Datasnap.
This application includes a Client and Server.
The Client is a mobile application (Android) and the Server is a Windows Service that's is connected to a firebird database.
I have an Object:-
TJob = class(TObject)
private
FID: Integer;
FThe_Name: String;
FImage: TMemoryStream;
public
constructor Create;
destructor Destroy;
end;
constructor TJob.Create;
begin
inherited;
FImage := TMemoryStream.Create;
end;
destructor TJob.Destroy;
begin
FreeAndNil(FImage);
inherited;
end;
I get an access violation when I try to save the image on the server to the DB and when I try and open and display the image on the client.
I have a standalone multidevice application that use the same functionality(Getting, Saving and displaying of an Image) as the Client/Server and works.
Client displaying the image on the form:-
if (Job.Image.Size > 0) then
begin
rectangle.Fill.Kind := TBrushKind.Bitmap;
rectangle.Fill.Bitmap.Bitmap.LoadFromStream(Job.Image);
rectangle.Repaint;
Layout.Repaint;
end;
Client getting the Image from the form:-
if not(rectangle.Fill.Bitmap.Bitmap.IsEmpty) then
begin
Job.Image.Seek(0, soFromBeginning);
rectangle.Fill.Bitmap.Bitmap.SaveToStream(Job.Image);
Job.Image.Position := 0;
end;
Server Saving the Image to DB:-
Job.Image.Position := 0;
(TBlobField(FieldByName('MyImage'))).SaveToStream(Job.Image);
Server getting the Image from DB:-
(TBlobField(FieldByName('MyImage'))).SaveToStream(Job.Image);
The Standalone application works using the same however I get errors when trying to either save or display an image.
I have populated the DB with various formats of images, which I can view in the DB, but not from the Client(AV).
Any ideas on what I've done wrong and examples on how to solve fix?
Thanks
Server getting the Image from DB:-
PngImage := TPngImage.Create;
MemoryStream := TMemoryStream.Create;
try
(TBlobField(FieldByName('Image'))).SaveToStream(MemoryStream);
MemoryStream.Position := 0;
PngImage.LoadFromStream(MemoryStream);
Job.Image_AsStr := Base64FromPngImage(PngImage);
finally
MemoryStream.Free;
end;
Client displaying the image on the form:-
if (Job.Image_AsStr <> '') then
begin
rImage.Fill.Kind := TBrushKind.Bitmap;
rImage.Fill.Bitmap.Bitmap := BitmapFromBase64(Job.Image_AsStr);
rCustomer_Signature.Repaint;
lCustomer_Signature.Repaint;
end;
Client getting the Image from the form:-
if not(rImage.Fill.Bitmap.Bitmap.IsEmpty) then
begin
rImage.Fill.Kind := TBrushKind.Bitmap;
Job.Image_AsStr := Base64FromBitmap(rImage.Fill.Bitmap.Bitmap);
end
else
Job.Image_AsStr := '';
Server Saving the Image to DB:-
if Job.Image_AsStr <> '' then
begin
MemoryStream := TMemoryStream.Create;
try
PngImage := PngImageFromBase64(Job.Image_AsStr);
PngImage.SaveToStream(MemoryStream);
MemoryStream.Position := 0;
Params[1].LoadFromStream(MemoryStream, ftBlob);
finally
MemoryStream.Free;
end;
end
else
Params[1].Clear;
On my experience the image arrives back at the Server as a PngImage even though
its been packaged as a BMP.
I can now confirm that I've installed and tested on a Android phone.
*Note. The original question posted was about using a TMemoryStream, these examples uses a String.
I am trying to create https server in lazarus using synapse but I am failing. I want to mys server receive data from other https clients.
I am sending requests with my browser using https://localhost:1500 and mys server is receiving signals. But when I try to read sent data I receive nothing. When I tested simple http server all worked fine. But now in case of https it is not working. I am using ubuntu 15.04 as my OS
s := ASocket.RecvString(timeout); //returns noething
My sample code:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses
blcksock, sockets, Synautil, ssl_openssl, ssl_openssl_lib;
procedure AttendConnection(ASocket: TTCPBlockSocket);
var
timeout: integer;
s: string;
method, uri, protocol: string;
OutputDataString: string;
ResultCode: integer;
begin
timeout := 1000;
WriteLn('Received headers+document from browser:');
//read request line
s := ASocket.RecvString(timeout);
WriteLn(s);
method := fetch(s, ' ');
uri := fetch(s, ' ');
protocol := fetch(s, ' ');
//read request headers
repeat
s := ASocket.RecvString(Timeout);
WriteLn(s);
until s = '';
// Now write the document to the output stream
if uri = '/' then
begin
// Write the output document to the stream
OutputDataString :=
'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"'
+ ' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">' + CRLF
+ '<html><h1>Teste</h1></html>' + CRLF;
// Write the headers back to the client
ASocket.SendString('HTTP/1.0 200' + CRLF);
ASocket.SendString('Content-type: Text/Html' + CRLF);
ASocket.SendString('Content-length: ' + IntTostr(Length(OutputDataString)) + CRLF);
ASocket.SendString('Connection: close' + CRLF);
ASocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF);
ASocket.SendString('Server: Servidor do Felipe usando Synapse' + CRLF);
ASocket.SendString('' + CRLF);
// if ASocket.lasterror <> 0 then HandleError;
// Write the document back to the browser
ASocket.SendString(OutputDataString);
end
else
ASocket.SendString('HTTP/1.0 404' + CRLF);
end;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
ListenerSocket, ConnectionSocket: TTCPBlockSocket;
begin
ListenerSocket := TTCPBlockSocket.Create;
ConnectionSocket := TTCPBlockSocket.Create;
ListenerSocket.CreateSocket;
ListenerSocket.SSL.CertificateFile := '/home/imants/projects/apps/medieval/bin/40669199_localhost_8080.cert';
ListenerSocket.SSL.PrivateKeyFile := '/home/imants/projects/apps/medieval/bin/40669199_localhost_8080.key';
ListenerSocket.SSLDoConnect;
ListenerSocket.setLinger(true,10);
ListenerSocket.bind('localhost','1500');
ListenerSocket.listen;
repeat
if ListenerSocket.canread(1000) then
begin
ConnectionSocket.Socket := ListenerSocket.accept;
WriteLn('Attending Connection. Error code (0=Success): ', ConnectionSocket.lasterror);
AttendConnection(ConnectionSocket);
ConnectionSocket.CloseSocket;
end;
until false;
ListenerSocket.Free;
ConnectionSocket.Free;
end;
end.
There are two sources, that I know of, with an example for a HTTP(s) server in Synapse.
The first example is in the Synapse stable package (release 40). Although I would recommend you use the SVN version (you can use the Download Snapshot button on that page) you can still use the examples in the "release 40 package".
The example in synapse40\source\demo\httpsserv should be usable as HTTPS-server. If it's not you could take the httpserv (HTTP) example and change it as shown here. (But I think the httpsserv is just the same with those modifications)
If you're on Linux (Lazarus) you'll need to change every occurrence of winsock to synsock and remove any windows-clause.
Another example can be found here. (Direct download of SynHttp.zip) As far as I could see it also has HTTPS-server functionality.
I know that you want to use Synapse, but you may want to take a look at Indy. I have been developing server/client apps with indy for some years and I like it. It's working fine with windows and linux (32bit, 64bit, arm...) and has some nice features. You could use the TIdHTTPServer component. Moreover get an IOHandlerSSLOpenSSL. The event OnCommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo) is the most important one. It allows access to the Request (like A ARequestInfo.Document) and to your HTTP response (AResponseInfo).
I'm trying to upload a file .txt in my web space, but then the problems start, the code I tried is this:
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdExplicitTLSClientServerBase, IdFTP, StdCtrls;
procedure TForm1.Button1Click(Sender: TObject);
var
FTP:tidftp;
begin
FTP.Host:='website.altervista.org';
FTP.Username:='website';
FTP.Password:='password';
FTP.Port:=25;
FTP.Connect;
FTP.Put('C:\Users\user\Desktop\text.txt');
FTP.Quit;
end;
I'm not getting any error, but when I start the program and I click on the button, I get an error:
and immediately after another:
and the button disappears.
Why? Thanks!
You have to instantiate the TIdFTP object for your local variable FTP before you access it. So try to use this:
procedure TForm1.Button1Click(Sender: TObject);
var
FTP: TIdFTP;
begin
FTP := TIdFTP.Create(nil);
try
FTP.Host := 'serioussamhd.altervista.org';
FTP.Username := 'serioussamhd';
FTP.Password := 'password';
FTP.Port := 21;
FTP.Connect;
FTP.Put('C:\Users\user\Desktop\text.txt');
FTP.Quit;
finally
FTP.Free;
end;
end;
You must create the instance of the tidftp first.
var
FTP:tidftp;
begin
FTP:=Tidftp.Create(nil); //create the instance
try
FTP.Host:='siteweb.altervista.org';
FTP.Username:='siteweb';
FTP.Password:='password';
FTP.Port:=25;
FTP.Connect;
FTP.Put('C:\Users\user\Desktop\text.txt');
FTP.Quit;
finally
FTP.Free;
end;
end;
I have this code inside thread and when I call terminate it terminates fast if it is not in the middle of http request , but when I have 20 threads it takes time to finish http request and exit the thread.
CODE:
procedure TParser.Execute;
var
i,b:integer;
t:string;
begin
http := thttpsend.create;
http.KeepAlive:=true;
Ftest:=TStringList.Create;
{http.timeout:=5000;}
for i:=0 to FStartNum.Count do
if FLocalVariable<FStartNum.Count-FThreadCount then
begin
if terminated then begin
exit;
end
else
EnterCriticalSection(Form1.StringSection);
try
FLocalVariable := form1.GlobalVariable;
Inc(FLocalVariable);
form1.GlobalVariable := FLocalVariable;
finally
LeaveCriticalSection(Form1.StringSection);
http.Clear;
HTTP.HTTPMethod('GET',FStartNum.Strings[FLocalVariable]);
Ftest.LoadFromStream(HTTP.Document);
Synchronize(progress);
parse;
Ftest.Clear;
end;
end;
end;
How do I stop this HTTP request from main form :
HTTP.HTTPMethod('GET',FStartNum.Strings[FLocalVariable]);
Ftest.LoadFromStream(HTTP.Document);
Thanks
Edit: Termination code :
for i:=Low(fparser) to High(fparser) do
begin
Fparser[i].Terminate();
end;
Call the THttpSend.Abort() method to stop a transfer that is in progress. You can do that in the THttpSend.OnStatus event, eg:
procedure TParser.Execute;
var
...
begin
http := THttpSend.Create;
http.OnStatus := HttpStatus;
...
end;
procedure TParser.HttpStatus(Sender: TObject; Reason: THookSocketReason; const Value: String);
begin
if Terminated then Http.Abort;
end;