Atozed Forums

Atozed Forums > Indy > Indy General Discussion > IdTCPServer Freeze on Delphi
Full Version: IdTCPServer Freeze on Delphi
You're currently viewing a stripped down version of our content. View the full version with proper formatting.

3ddark

04-18-2020, 08:30 PM
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)

[attachment=227]

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.

rlebeau

04-18-2020, 09:37 PM
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.

3ddark

04-19-2020, 11:48 AM
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.

rlebeau

04-20-2020, 07:11 PM
(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.

3ddark

04-21-2020, 08:39 AM
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

rlebeau

04-21-2020, 06:05 PM
(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).

3ddark

04-22-2020, 05:59 AM
Remy,
Thank you for your help.

3ddark

04-23-2020, 01:57 PM
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

rlebeau

04-23-2020, 04:48 PM
(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.

TangoEcho

01-28-2022, 02:24 PM
(04-18-2020, 09:37 PM)Hello Remy, I admire your knowledge and presence in various forums.I am an oldtimer from TurboPascal, but a rookie in Lazarus and Indy. In Lazarus I used your example below for IdTCPserver after fighting for weeks with other non-working examples from the web. I added just a few buttons and a Memo to your code. Nevertheless, I can not make your example work right. It does establish connection and receive messages. However, when an active connection is terminated, the remote client is disconnected but the server does not respond to it by decrementing the client count. I did some tracing with Lazarus Debugger and found that TForm1.IdTCPServer1Disconnect LNotify.Notify does not activate TClientDisconnectedNotify.DoNotify. Below is the trace info. Did your code below actually run in Lazarus? If so, what do you think is my error? I am on Windows 10, Lazarus v2.0.10 r63526. Behaviour:-------------------------------Client application is Putty in raw mode Wrote: [ -> ]IdTCPServer ON CLIENT CONNECT (debugger tracing --- everything seems to go right through a series of breakpoints):

procedure TForm1.IdTCPServer1Connect  --> LNotify.Notify; --> TClientConnectedNotify.DoNotify;  --> TForm1.HandleClientConnected --> UpdateClientsCount;

--> Listbox1 correctly updated to 1 user & Putty connected

Server is receiveing messages right.



Now Putty is intentionally rudely closed by close window. From now on IdTCPserver behaves wrong.



IdTCPServer ON CLIENT DISCONNECT:

Lazarus Debugger correctly catches EIdConnClosedGracefully --> Continue

breakpoint triggered: TForm1.IdTCPServer1Disconnect --> trace to Lnotify.Notify

trace into: TIdCustomTCPServer.DoDisconnect

trace into: TIdCustomTCPServer.ContextDisconnected

trace into: TIdContext.AfterRun  --> FContextList.Remove(Self);

trace into: TIdTask.DoAfterRun;

trace into: TIdThreadWithTask.AfterRun;

trace into: TIdThread.Execute;  --> Exception: ConnectionClosedGracefully --> Terminate;



... and then Debugger stops tracing, server application is alive and client count has not been updated, Listbox1 still contains a connection that is supposed not to exist any more.



Why is the execution path between TForm1.IdTCPServer1Disconnect LNotify.Notify; --> TClientDisconnectedNotify.DoNotify;  lost ???



The same behaviour happens if disconnect is triggered from the server side by receiving 'E'.
In your code input 'E' from client is supposed to disconnect the remote client. Putty in my case is disconnected indeed, but UpdateClientsCount on the server side does not happen.


Code:
unit stringserverunit3;

// IdTCPserver code from rlebeau example at https://www.atozed.com/forums/printthread.php?tid=1625

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
  IdGlobal,
  IdContext,
  IdSync,
  IdCustomTCPServer,
  IdBaseComponent,
  IdTCPConnection,
  IdTCPServer;

type

  { TForm1 }

  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;

    ListBox1: TListBox;
    btn_start: TButton;
    btn_stop: TButton;
    btn_clear: TButton;
    Memo1: TMemo;

    procedure btn_clearClick(Sender: TObject);
    procedure btn_startClick(Sender: TObject);
    procedure btn_stopClick(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Disconnect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
    function  GetNow():String;
  private
    procedure HandleClientConnected(AContext: TIdContext; APeerIP: string; APeerPort: TIdPort);
    procedure HandleClientDisconnected(AContext: TIdContext);
    procedure UpdateClientsCount;
  public

  end;


var
  Form1: TForm1;

// ... listening port
      const LISTENING_PORT = 6000;

implementation

{$R *.lfm}


Type

{ TMyMemoSync MessageToMemo Syncing Mechanism }
  TMyMemoSync = Class(TIDSync)
  private
    FContent: String;
    FDestination: Tmemo;
    Constructor Create(const Content: String; Destination: TMemo); overload;
  protected
    Procedure DoSynchronize; override;
  public
  end;

constructor TMyMemoSync.Create(const Content: String; Destination: TMemo);
begin
  inherited Create;
  FContent := Content;
  FDestination := Destination;
end;

procedure TMyMemoSync.DoSynchronize;
begin
  (* inherited;  compiler tega ne požre *)
  FDestination.Append(FContent);
end;


// 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...

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;


{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdTCPServer1.DefaultPort := LISTENING_PORT;
  IdTCPServer1.Active := False;
end;

procedure TForm1.btn_startClick(Sender: TObject);
begin
  IdTCPServer1.DefaultPort := LISTENING_PORT;
  IdTCPServer1.Active := True;
  Memo1.Append(getnow + 'server STARTED');
end;

procedure TForm1.btn_stopClick(Sender: TObject);
begin
  IdTCPServer1.Active   := false;
  Memo1.Append(getnow + 'server STOPPED');
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
  PeerIP: string;
  PeerPort: TIdPort;
  LNotify: TClientConnectedNotify;

  msgToClient: string;
begin
  PeerIP := AContext.Binding.PeerIP;
  PeerPort := AContext.Binding.PeerPort;

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

  msgToClient := 'connected';
  AContext.Connection.IOHandler.WriteLn( msgToClient );

end;


procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
  LNotify: TClientDisconnectedNotify;
begin
  LNotify := TClientDisconnectedNotify.Create;
  LNotify.Context := AContext;
  LNotify.Notify;
end;


procedure TForm1.HandleClientConnected(AContext: TIdContext; APeerIP: string; APeerPort: TIdPort);
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.btn_clearClick(Sender: TObject);
begin
    Memo1.Clear;
end;


function TForm1.getNow(): String;
begin
    Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ';
end;


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

  With TMyMemoSync.Create(data, Memo1) do
  begin
    Synchronize;
    Free;
  end;

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


end.





rlebeauYour 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.
Atozed Forums > Indy > Indy General Discussion > IdTCPServer Freeze on Delphi