Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
IdTCPServer Freeze on Delphi
#1
Hello,
I did a test for IdTCPServer and Client.
The results differed slightly and were interesting.

TCPServer test on Delphi, after 1500+ client connected then freeze,
But lazarus is works fine

Same code same component(Indy10), different result!!!

Test PC Windows 10 64 Bit
Delphi 10.3 Community vs Lazarus 2.0.8 (fpc 3.0.4)
And Delphi 7 same result freeze(Thread creation error)

   

Code:
//Server side code
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
  IdContext, IdTCPServer, IdCustomTCPServer;

type

  { TForm1 }

  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
  private

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
  List : TIdContextList;
begin
  ListBox1.Items.BeginUpdate;
  try
    ListBox1.Items.Add(AContext.Binding.PeerIP +':'+ AContext.Binding.PeerPort.ToString);
  finally
    ListBox1.Items.EndUpdate;
  end;

  if IdTCPServer1.Active then
  begin
    List := IdTCPServer1.Contexts.LockList;
    try
      Form1.Caption := 'Server - Client : '  +  List.Count.ToString;
    finally
      IdTCPServer1.Contexts.UnlockList;
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdTCPServer1.Active := True;
end;

procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
  n1: Integer;
begin
  n1 := ListBox1.Items.IndexOf(AContext.Binding.PeerIP +':'+ AContext.Binding.PeerPort.ToString);
  if n1 > -1 then
    ListBox1.Items.Delete(n1);
end;

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
  data: string;
begin
  data := AContext.Connection.IOHandler.ReadLn;

  if data= 'E' then
    AContext.Connection.Disconnect;
end;

end.
Code:
//Client side code
unit Unit2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, Vcl.StdCtrls;

type
  TForm2 = class(TForm)
    edtIP: TEdit;
    edtPort: TEdit;
    Button1: TButton;
    Button2: TButton;
    edtClient: TEdit;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    a: Array[1..10000] Of TIdTCPClient;
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.Button1Click(Sender: TObject);
var
  I:integer;
begin
  for  I := 1 to StrToInt(edtClient.Text) do
  begin
    try
      a[I] := nil;

      a[I]:= TIdTCPClient.Create( NIL );
      a[I].Host := edtIP.Text;
      a[I].Port := StrToInt(edtPort.Text);
      a[I].Connect;
      a[I].IOHandler.WriteLn( 'main|ADDNEW|1234abcd|' + IntToStr(i) + ' |t2|t3|t4|t5|t6|t7|t8|NEW' );
      Self.Caption:= 'Clients  : ' + IntToStr(i);
      Sleep(10);
      Application.ProcessMessages;
    except

    end;
  end;
end;

end.
Reply
#2
Your server's OnConnect and OnDisconnect event handlers are not thread-safe, which can easily cause deadlocks (among other problems).

The OnConnect, OnDisconnect, and OnExecute events are fired in the context of worker threads, so they MUST synchronize with the main UI thread when accessing UI controls.  Simply calling (Begin|End)Update on ListBox1, or locking the server's Contexts list, is NOT adequate synchronization.

Use the TThread.Synchronize() or TThread.Queue() methods, or Indy's TIdSync or TIdNotify classes.  For example:

Code:
//Server side code
unit Unit1;

{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
  IdContext, IdTCPServer, IdCustomTCPServer;

type

  { TForm1 }

  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
  private
    procedure HandleClientConnected(AContext: TIdContext; APeerIP: string; APeerPort: TIdPort);
    procedure HandleClientDisconnected(AContext: TIdContext);
    procedure UpdateClientsCount;
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

// FreePascal does not implement overloads of TThread.Synchronize()
// and TThread.Queue() that take anonymous procedures as input, but
// Delphi does...

// for this example, I'm using asynchronous UI updates, because 1) the
// server logic is not dependent on waiting for the UI, and 2) asynchronous
// avoids a deadlock when deactivating the server and a client tries to
// update the UI...

{$IFDEF FPC}
uses
  IdSync;

type
  TClientConnectedNotify = class(TIdNotify)
  protected
    Context: TIdContext;
    PeerIP: string;
    PeerPort: TIdPort;
    procedure DoNotify; override;
  end;

  TClientDisconnectedNotify = class(TIdNotify)
  protected
    Context: TIdContext;
    procedure DoNotify; override;
  end;

procedure TClientConnectedNotify.DoNotify;
begin
  Form1.HandleClientConnected(Context, PeerIP, PeerPort);
end;

procedure TClientDisconnectedNotify.DoNotify;
begin
  Form1.HandleClientDisconnected(Context);
end;
{$ENDIF}

{ TForm1 }

procedure TForm1.HandleClientConnected(APeerIP: string; APeerPort: TIdPort; AContext: TIdContext);
begin
  ListBox1.Items.AddObject(APeerIP + ':' + APeerPort.ToString, AContext);
  UpdateClientsCount;
end;

procedure TForm1.HandleClientDisconnected(AContext: TIdContext);
var
  n1: Integer;
begin
  n1 := ListBox1.Items.IndexOfObject(AContext);
  if n1 > -1 then
    ListBox1.Items.Delete(n1);
  UpdateClientsCount;
end;

procedure TForm1.UpdateClientsCount;
begin
  Caption := 'Server - Client : ' + ListBox1.Items.Count.ToString;
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
  PeerIP: string;
  PeerPort: TIdPort;
  {$IFDEF FPC}
  LNotify: TClientConnectedNotify;
  {$ENDIF}
begin
  PeerIP := AContext.Binding.PeerIP;
  PeerPort := AContext.Binding.PeerPort.ToString;

  {$IFDEF FPC}

  LNotify := TClientConnectedNotify.Create;
  LNotify.Context := AContext;
  LNotify.PeerIP := PeerIP;
  LNotify.PeerPort := PeerPort;
  LNotify.Notify;

  {$ELSE}

  TThread.Queue(nil,
    procedure
      Form1.HandleClientConnected(AContext, PeerIP, PeerPort);
    end
  );

  {$ENDIF}
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdTCPServer1.Active := True;
end;

procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
{$IFDEF FPC}
var
  LNotify: TClientDisconnectedNotify;
{$ENDIF}
begin
  {$IFDEF FPC}

  LNotify := TClientDisconnectedNotify.Create;
  LNotify.Context := AContext;
  LNotify.Notify;

  {$ELSE}

  TThread.Queue(nil,
    procedure
      Form1.HandleClientDisconnected(AContext);
    end
  );

  {$ENDIF}
end;

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
  data: string;
begin
  data := AContext.Connection.IOHandler.ReadLn;
  if data = 'E' then
    AContext.Connection.Disconnect;
end;

end.

Reply
#3
Thank you Remy for answer.

I edited and tested the code with your suggestion. The result is the same for Delphi.

I test on Ubuntu(18.04) Console app. I got the same result on Linux

Code:
//Delphi Vcl App for Windows
unit Unit1;

interface

uses
    Winapi.Windows
  , Winapi.Messages
  , System.SysUtils
  , System.Variants
  , System.Classes
  , Vcl.Controls
  , Vcl.StdCtrls
  , Vcl.Forms
  , IdTCPServer
  , IdContext
  , IdBaseComponent
  , IdComponent
  , IdCustomTCPServer;

type
  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
  private
    procedure HandleClientConnected(AContext: TIdContext; APeerIP: string; APeerPort: Integer);
    procedure HandleClientDisconnected(AContext: TIdContext);
    procedure UpdateClientsCount;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdTCPServer1.Active := True;
end;

procedure TForm1.HandleClientConnected(AContext: TIdContext; APeerIP: string; APeerPort: Integer);
begin
  ListBox1.Items.AddObject(APeerIP + ':' + APeerPort.ToString, AContext);
  UpdateClientsCount;
end;

procedure TForm1.HandleClientDisconnected(AContext: TIdContext);
var
  n1: Integer;
begin
  n1 := ListBox1.Items.IndexOfObject(AContext);
  if n1 > -1 then
    ListBox1.Items.Delete(n1);
  UpdateClientsCount;
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
  PeerIP: string;
  PeerPort: Integer;
begin
  PeerIP := AContext.Binding.PeerIP;
  PeerPort := AContext.Binding.PeerPort;

  TThread.Queue(nil,
    procedure
    begin
      Form1.HandleClientConnected(AContext, PeerIP, PeerPort);
    end
  );
end;

procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
begin
  TThread.Queue(nil,
    procedure
    begin
      Form1.HandleClientDisconnected(AContext);
    end
  );
end;

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
  data: string;
begin
  data := AContext.Connection.IOHandler.ReadLn;
  if data = 'E' then
    AContext.Connection.Disconnect;
end;

procedure TForm1.UpdateClientsCount;
var
  List : TIdContextList;
begin
  List := IdTCPServer1.Contexts.LockList;
  try
    Caption := 'Server - Client : ' + List.Count.ToString;
  finally
    IdTCPServer1.Contexts.UnlockList;
  end;
end;

end.


Code:
//Delphi Console App for Linux
program Project3;

{$APPTYPE CONSOLE}

{$R *.res}

uses
    System.SysUtils
  , System.Classes
  , System.Threading
  , IdContext
  , IdBaseComponent
  , IdComponent
  , IdCustomTCPServer
  , IdTCPServer;

type
  TSocketServer = class
  private
    procedure HandleClientConnected(AContext: TIdContext; APeerIP: string; APeerPort: Integer);
    procedure HandleClientDisconnected(AContext: TIdContext);
    procedure UpdateClientsCount;
  public
    IdTCPServer1: TIdTCPServer;

    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
    constructor Create();
    destructor Destroy; override;
  end;

var
  Server: TSocketServer;

constructor TSocketServer.Create();
begin
  inherited;
  IdTCPServer1 := TIdTCPServer.Create;
  IdTCPServer1.DefaultPort := 20000;

  IdTCPServer1.OnConnect := IdTCPServer1Connect;
  IdTCPServer1.OnDisconnect := IdTCPServer1Disconnect;
  IdTCPServer1.OnExecute := IdTCPServer1Execute;

  IdTCPServer1.Active := True;
end;

destructor TSocketServer.Destroy;
begin
  IdTCPServer1.Active := False;
  inherited;
end;

procedure TSocketServer.HandleClientConnected(AContext: TIdContext; APeerIP: string; APeerPort: Integer);
begin
  Writeln(AContext.Binding.PeerIP + ':' + AContext.Binding.PeerPort.ToString);
  UpdateClientsCount;
end;

procedure TSocketServer.HandleClientDisconnected(AContext: TIdContext);
begin
  UpdateClientsCount;
end;

procedure TSocketServer.IdTCPServer1Connect(AContext: TIdContext);
var
  PeerIP: string;
  PeerPort: Integer;
begin
  PeerIP := AContext.Binding.PeerIP;
  PeerPort := AContext.Binding.PeerPort;

  TThread.Queue(nil,
    procedure
    begin
      HandleClientConnected(AContext, PeerIP, PeerPort);
    end
  );
end;

procedure TSocketServer.IdTCPServer1Disconnect(AContext: TIdContext);
begin
  TThread.Queue(nil,
    procedure
    begin
      HandleClientDisconnected(AContext);
    end
  );
end;

procedure TSocketServer.IdTCPServer1Execute(AContext: TIdContext);
var
  data: string;
begin
  data := AContext.Connection.IOHandler.ReadLn;
  if data= 'E' then
    AContext.Connection.Disconnect;
end;

procedure TSocketServer.UpdateClientsCount;
var
  List : TIdContextList;
begin
  if IdTCPServer1.Active then
  begin
    List := IdTCPServer1.Contexts.LockList;
    try
      Writeln('Server - Client : ' + List.Count.ToString);
    finally
      IdTCPServer1.Contexts.UnlockList;
    end;
  end;
end;

begin
  Server := TSocketServer.Create;
  try
    while True do
    begin
      try
        Sleep(1);
      except
        on E: Exception do
          Writeln(E.ClassName, ': ', E.Message);
      end;
    end;
  finally
    Server.Free;
  end;
end.
Reply
#4
(04-19-2020, 11:48 AM)3ddark Wrote: I edited and tested the code with your suggestion. The result is the same for Delphi.

The VCL code looks fine. There should be no freezing.

(04-19-2020, 11:48 AM)3ddark Wrote: I test on Ubuntu(18.04) Console app. I got the same result on Linux

Your Linux code is not servicing the TThread.Queue() requests, so they never execute your handlers. Since you are not using a UI message loop, you need a manual loop that calls the RTL's CheckSynchronize() function periodically.

It is also important NOT to access the members of TIdContext asynchronously, especially after a disconnect, since the TIdContext object will be destroyed after the OnDisconnect handler exits, and will likely not exist anymore before (or worse, while) your TThread.Queue() handler is run. That is why in the code I provided you, I use the TIdContext pointer only as a lookup key in the TListBox, nothing more. In your Linux code, you don't need the TIdContext pointer at all.

Try this:

Code:
//Delphi Console App for Linux
program Project3;

{$APPTYPE CONSOLE}

{$R *.res}

uses
    System.SysUtils
  , System.Classes
  , System.Threading
  , IdContext
  , IdBaseComponent
  , IdComponent
  , IdCustomTCPServer
  , IdTCPServer;

type
  TSocketServer = class
  private
    procedure HandleClientConnected(APeerIP: string; APeerPort: Integer);
    procedure HandleClientDisconnected();
    procedure UpdateClientsCount;
  public
    IdTCPServer1: TIdTCPServer;

    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
    constructor Create();
    destructor Destroy; override;
  end;

var
  Server: TSocketServer;

constructor TSocketServer.Create();
begin
  inherited;
  IdTCPServer1 := TIdTCPServer.Create;
  IdTCPServer1.DefaultPort := 20000;

  IdTCPServer1.OnConnect := IdTCPServer1Connect;
  IdTCPServer1.OnDisconnect := IdTCPServer1Disconnect;
  IdTCPServer1.OnExecute := IdTCPServer1Execute;

  IdTCPServer1.Active := True;
end;

destructor TSocketServer.Destroy;
begin
  IdTCPServer1.Active := False;
  inherited;
end;

procedure TSocketServer.HandleClientConnected(APeerIP: string; APeerPort: Integer);
begin
  Writeln(APeerIP + ':' + APeerPort.ToString);
  UpdateClientsCount;
end;

procedure TSocketServer.HandleClientDisconnected();
begin
  UpdateClientsCount;
end;

procedure TSocketServer.IdTCPServer1Connect(AContext: TIdContext);
var
  PeerIP: string;
  PeerPort: Integer;
begin
  PeerIP := AContext.Binding.PeerIP;
  PeerPort := AContext.Binding.PeerPort;

  TThread.Queue(nil,
    procedure
    begin
      HandleClientConnected(PeerIP, PeerPort);
    end
  );
end;

procedure TSocketServer.IdTCPServer1Disconnect(AContext: TIdContext);
begin
  TThread.Queue(nil,
    procedure
    begin
      HandleClientDisconnected();
    end
  );
end;

procedure TSocketServer.IdTCPServer1Execute(AContext: TIdContext);
var
  data: string;
begin
  data := AContext.Connection.IOHandler.ReadLn;
  if data = 'E' then
    AContext.Connection.Disconnect;
end;

procedure TSocketServer.UpdateClientsCount;
var
  List : TIdContextList;
  Count: Integer;
begin
  if IdTCPServer1.Active then
  begin
    List := IdTCPServer1.Contexts.LockList;
    try
      Count := List.Count;
    finally
      IdTCPServer1.Contexts.UnlockList;
    end;
  end else begin
    Count := 0;
  end;
  Writeln('Server - Client : ' + Count.ToString);
end;

begin
  Server := TSocketServer.Create;
  try
    while True do
    begin
      try
        CheckSynchronize(100);
      except
        on E: Exception do
          Writeln(E.ClassName, ': ', E.Message);
      end;
    end;
  finally
    Server.Free;
  end;
end.

Reply
#5
No freezing on vcl side. But when the number of clients exceeds 1500, the server freezes.

If you test it, you will see that it is frozen
Reply
#6
(04-21-2020, 08:39 AM)3ddark Wrote: when the number of clients exceeds 1500, the server freezes.

1500 *simultaneous* clients? Because that would mean your process is running 1500 concurrent threads (1 thread per client), which is likely to take up way too much memory. The default thread stack size is 1-4MB, depending on project settings, so 1500 simultaneous clients would be using 1.5-6GB of memory. Indy is not designed for that kind of load. You would need to reduce the number of simultaneous clients, or lower the default stack size. But, on Windows at least, you really need to use Overlapped I/O or I/O Completion Ports to handle that kind of load efficiently, and that is not supported by Indy at this time.

(04-21-2020, 08:39 AM)3ddark Wrote: If you test it, you will see that it is frozen

I can't test it right now (no working IDE).

Reply
#7
Remy,
Thank you for your help.
Reply
#8
Max Stack Size reduce the 1048576(default) to 65536
I tested for 5000 Clients. Result is excellent

But I still don't know the stack size unit. Smile
bytes, kb or any ???

PC Configuration:
Windows 10 x64
16GB Ram
Reply
#9
(04-23-2020, 01:57 PM)3ddark Wrote: Max Stack Size reduce the 1048576(default) to 65536
I tested for 5000 Clients. Result is excellent

Lowering the stack size from 1MB to 64K lowers the memory usage from 1GB for 1500 clients down to 312MB for 5000 clients. Much more manageable for the system.

(04-23-2020, 01:57 PM)3ddark Wrote: But I still don't know the stack size unit. Smile
bytes, kb or any ???

See Thread Stack Size on MSDN.

Reply


Forum Jump:


Users browsing this thread: 1 Guest(s)