delphiindy10delphi-10.2-tokyo

TIdTCPServer hangs when setting Active = false


I was looking at this example for using TIdTCPServer/client components and I found that if there are any clients then the server component will hang when you change active to false. Specifically, it hangs on the call to the Windows "ExitThread" function call for the context thread.

To reproduce the behavior:

  1. run the server,
  2. click the "Start Server" button,
  3. run a client,
  4. click the connect button
  5. click the "Stop Server" button

I want a simple TCP server to monitor a process over the LAN but I can't figure out how to prevent this lock up. I have found a lot of information that skirts around this but nothing has made sense to me yet. I'm using Delphi 10.2 on Win 8.1 with Indy 10.6.2.5366.


Solution

  • ExitThread() can't hang, unless a DLL is misbehaving in its DllMain/DllEntryPoint() handler, causing a deadlock in the DLL loader. But, the server's Active property setter can certainly hang, such as if any of the client threads are deadlocked.

    The example you linked to is NOT a good example to follow. The threaded event handlers are doing things that are not thread-safe. They are accessing UI controls without syncing with the main UI thread, which can cause many problems including deadlocks and dead UI controls. And the server's broadcast method is implemented all wrong, making it prone to deadlocks, crashes, and data corruption.

    Whoever wrote that example (not me) clearly didn't know what they were doing. It needs to be rewritten to take thread safety into account properly. Try something more like this instead:

    unit UServer;
    
    interface
    
    uses
      Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
      Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdComponent, Vcl.StdCtrls,
      IdBaseComponent, IdCustomTCPServer, IdTCPServer, Vcl.ExtCtrls;
    
    type
      TFServer = class(TForm)
        Title         : TLabel;
    
        btn_start     : TButton;
        btn_stop      : TButton;
        btn_clear     : TButton;
    
        clients_connected : TLabel;
    
        IdTCPServer   : TIdTCPServer;
        Label1        : TLabel;
        Panel1        : TPanel;
        messagesLog   : TMemo;
    
        procedure FormShow(Sender: TObject);
    
        procedure btn_startClick(Sender: TObject);
        procedure btn_stopClick(Sender: TObject);
        procedure btn_clearClick(Sender: TObject);
    
        procedure IdTCPServerConnect(AContext: TIdContext);
        procedure IdTCPServerDisconnect(AContext: TIdContext);
        procedure IdTCPServerExecute(AContext: TIdContext);
        procedure IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
                                    const AStatusText: string);
    
      private
        { Private declarations }
    
        procedure broadcastMessage(p_message : string);
        procedure Log(p_who, p_message: string);
        procedure UpdateClientsConnected(ignoreOne: boolean);
    
      public
        { Public declarations }
    
      end;
      // ...
    
    var
      FServer     : TFServer;
    
    implementation
    
    uses
      IdGlobal, IdYarn, IdThreadSafe;
    
    {$R *.dfm}
    
    // ... listening port
    const
      GUEST_CLIENT_PORT = 20010;
    
    // *****************************************************************************
    //   CLASS : TMyContext
    //           HELPER CLASS FOR QUEUING OUTBOUND MESSAGES TO A CLIENT
    // *****************************************************************************
    type
      TMyContext = class(TIdServerContext)
      private
        FQueue: TIdThreadSafeStringList;
        FAnyInQueue: Boolean;
      public
        constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
        destructor Destroy; override;
        procedure AddToQueue(p_message: string);
        procedure CheckQueue;
      end;
    
    constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
    begin
      inherited Create(AConnection, AYarn, AList);
      FQueue := TIdThreadSafeStringList.Create;
      FAnyQueued := false;
    end;
    
    destructor TMyContext.Destroy;
    begin
      FQueue.Free;
      inherited;
    end;
    
    procedure TMyContext.AddToQueue(p_message: string);
    begin
      with FQueue.Lock do
      try
        Add(p_message);
        FAnyInQueue := true;
      finally
        FQueue.Unlock;
      end;
    end;
    
    procedure TMyContext.CheckQueue;
    var
      queue, tmpList  : TStringList;
      i               : integer;
    begin
      if not FAnyInQueue then Exit;
      tmpList := TStringList.Create;
      try
        queue := FQueue.Lock;
        try
          tmpList.Assign(queue);
          queue.Clear;
          FAnyInQueue := false;
        finally
          FQueue.Unlock;
        end;
        for i := 0 to tmpList.Count - 1 do begin
          Connection.IOHandler.WriteLn(tmpList[i]);
        end;
      finally
        tmpList.Free;
      end;
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onShow()
    //           ON FORM SHOW
    // *****************************************************************************
    procedure TFServer.FormShow(Sender: TObject);
    begin
      // ... INITIALIZE:
    
      // ... clear message log
      messagesLog.Lines.Clear;
    
      // ... zero to clients connected
      clients_connected.Caption := IntToStr(0);
    
      // ... set buttons
      btn_start.Visible := true;
      btn_start.Enabled := true;
      btn_stop.Visible  := false;
    
      // ... set context class
      IdTCPServer.ContextClass := TMyContext;
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : btn_startClick()
    //           CLICK ON START BUTTON
    // *****************************************************************************
    procedure TFServer.btn_startClick(Sender: TObject);
    begin
      btn_start.Enabled := false;
    
      // ... START SERVER:
    
      // ... clear the Bindings property ( ... Socket Handles )
      IdTCPServer.Bindings.Clear;
      // ... Bindings is a property of class: TIdSocketHandles;
    
      // ... add listening ports:
    
      // ... add a port for connections from guest clients.
      IdTCPServer.Bindings.Add.Port := GUEST_CLIENT_PORT;
      // ... etc..
    
      // ... ok, Active the Server!
      IdTCPServer.Active  := true;
    
      // ... hide start button
      btn_start.Visible   := false;
    
      // ... show stop button
      btn_stop.Visible    := true;
      btn_stop.Enabled    := true;
    
      // ... message log
      Log('SERVER', 'STARTED!');
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : btn_stopClick()
    //           CLICK ON STOP BUTTON
    // *****************************************************************************
    procedure TFServer.btn_stopClick(Sender: TObject);
    begin
      btn_stop.Enabled := false;
    
      // ... before stopping the server ... send 'good bye' to all clients connected
      broadcastMessage( 'Goodbye my Clients :)');
    
      // ... stop server!
      IdTCPServer.Active := false;
    
      // ... hide stop button
      btn_stop.Visible   := false;
    
      // ... show start button
      btn_start.Visible  := true;
      btn_start.Enabled  := true;
    
      // ... message log
      Log('SERVER', 'STOPPED!');
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : btn_clearClick()
    //           CLICK ON CLEAR BUTTON
    // *****************************************************************************
    procedure TFServer.btn_clearClick(Sender: TObject);
    begin
      //... clear messages log
      MessagesLog.Lines.Clear;
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onConnect()
    //           OCCURS ANY TIME A CLIENT IS CONNECTED
    // *****************************************************************************
    procedure TFServer.IdTCPServerConnect(AContext: TIdContext);
    var
      PeerIP      : string;
      PeerPort    : TIdPort;
    begin
    
      // ... OnConnect is a TIdServerThreadEvent property that represents the event
      //     handler signalled when a new client connection is connected to the server.
    
      // ... Use OnConnect to perform actions for the client after it is connected
      //     and prior to execution in the OnExecute event handler.
    
      // ... see indy doc:
      //     http://www.indyproject.org/sockets/docs/index.en.aspx
    
      // ... getting IP address and Port of Client that connected
      PeerIP    := AContext.Binding.PeerIP;
      PeerPort  := AContext.Binding.PeerPort;
    
      // ... message log ...........................................................
      Log('SERVER', 'Client Connected! Peer=' + PeerIP + ':' + IntToStr(PeerPort));
      // ...
    
      // ... update number of clients connected
      UpdateClientsConnected(false);
      // ...
    
      // ... send the Welcome message to Client connected
      AContext.Connection.IOHandler.WriteLn('Welcome GUEST Client :)');
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onDisconnect()
    //           OCCURS ANY TIME A CLIENT IS DISCONNECTED
    // *****************************************************************************
    procedure TFServer.IdTCPServerDisconnect(AContext: TIdContext);
    var
      PeerIP      : string;
      PeerPort    : TIdPort;
    begin
    
      // ... getting IP address and Port of Client that connected
      PeerIP    := AContext.Binding.PeerIP;
      PeerPort  := AContext.Binding.PeerPort;
    
      // ... message log ...........................................................
      Log('SERVER', 'Client Disconnected! Peer=' + PeerIP + ':' + IntToStr(PeerPort));
      // ...
    
      // ... update number of clients connected
      UpdateClientsConnected(true);
      // ...
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onExecute()
    //           ON EXECUTE THREAD CLIENT
    // *****************************************************************************
    procedure TFServer.IdTCPServerExecute(AContext: TIdContext);
    var
      PeerIP        : string;
      PeerPort      : TIdPort;
      msgFromClient : string;
    begin
    
      // ... OnExecute is a TIdServerThreadEvents event handler used to execute
      //     the task for a client connection to the server.
    
      // ... check for pending broadcast messages to the client
      TMyContext(AContext).CheckQueue;
      // ...
    
      // check for inbound messages from client
      if AContext.Connection.IOHandler.InputBufferIsEmpty then
      begin
        AContext.Connection.IOHandler.CheckForDataOnSource(100);
        AContext.Connection.IOHandler.CheckForDisconnect;
        if AContext.Connection.IOHandler.InputBufferIsEmpty then Exit;
      end;
    
      // ... received a message from the client
    
      // ... get message from client
      msgFromClient := AContext.Connection.IOHandler.ReadLn;
    
      // ... getting IP address, Port and PeerPort from Client that connected
      PeerIP    := AContext.Binding.PeerIP;
      PeerPort  := AContext.Binding.PeerPort;
    
      // ... message log ...........................................................
      Log('CLIENT', '(Peer=' + PeerIP + ':' + IntToStr(PeerPort) + ') ' + msgFromClient);
      // ...
    
      // ... process message (request) from Client
    
      // ...
    
      // ... send response to Client
    
      AContext.Connection.IOHandler.WriteLn('... response from server :)');
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onStatus()
    //           ON STATUS CONNECTION
    // *****************************************************************************
    procedure TFServer.IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
                                         const AStatusText: string);
    begin
    
      // ... OnStatus is a TIdStatusEvent property that represents the event handler
      //     triggered when the current connection state is changed...
    
      // ... message log
      Log('SERVER', AStatusText);
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   PROCEDURE : broadcastMessage()
    //               BROADCAST A MESSAGE TO ALL CLIENTS CONNECTED
    // *****************************************************************************
    procedure TFServer.broadcastMessage( p_message : string );
    var
      tmpList      : TIdContextList;
      contexClient : TIdContext;
      i            : integer;
    begin
    
      // ... send a message to all clients connected
    
      // ... get context Locklist
      tmpList := IdTCPServer.Contexts.LockList;
      try
        for i := 0 to tmpList.Count-1 do begin
          // ... get context ( thread of i-client )
          contexClient := tmpList[i];
    
          // ... queue message to client
          TMyContext(contexClient).AddToQueue(p_message);
        end;
      finally
        // ... unlock list of clients!
        IdTCPServer.Contexts.UnlockList;
      end;
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   PROCEDURE : Log()
    //               LOG A MESSAGE TO THE UI
    // *****************************************************************************
    procedure TFServer.Log(p_who, p_message : string);
    begin
      TThread.Queue(nil,
        procedure
        begin
          MessagesLog.Lines.Add('[' + p_who + '] - ' + FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ' + p_message);
        end
      );
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   PROCEDURE : UpdateClientsConnected()
    //               DISPLAY THE NUMBER OF CLIENTS CONNECTED
    // *****************************************************************************
    procedure TFServer.UpdateClientsConnected(ignoreOne: Boolean);
    var
      NumClients: integer;
    begin
      with IdTCPServer.Contexts.LockList do
      try
        NumClients := Count;
      finally
        IdTCPServer.Contexts.UnlockList;
      end;
    
      if ignoreOne then Dec(NumClients);
    
      TThread.Queue(nil,
        procedure
        begin
          clients_connected.Caption := IntToStr(NumClients);
        end
      );
    end;
    // .............................................................................
    
    end.
    

    unit UClient;
    
    interface
    
    uses
      Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
      Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IdBaseComponent,
      IdComponent, IdTCPConnection, IdTCPClient, IdThreadComponent;
    
    type
      TFClient = class(TForm)
    
        Label1        : TLabel;
        Label2        : TLabel;
    
        messageToSend : TMemo;
        messagesLog   : TMemo;
    
        btn_connect   : TButton;
        btn_disconnect: TButton;
        btn_send      : TButton;
    
        // ... TIdTCPClient
        IdTCPClient       : TIdTCPClient;
    
        // ... TIdThreadComponent
        IdThreadComponent : TIdThreadComponent;
    
        procedure FormShow(Sender: TObject);
    
        procedure btn_connectClick(Sender: TObject);
        procedure btn_disconnectClick(Sender: TObject);
        procedure btn_sendClick(Sender: TObject);
    
        procedure IdTCPClientConnected(Sender: TObject);
        procedure IdTCPClientDisconnected(Sender: TObject);
    
        procedure IdThreadComponentRun(Sender: TIdThreadComponent);
    
    
      private
        { Private declarations }
    
        procedure Log(p_who, p_message: string);
    
      public
        { Public declarations }
    
      end;
    
    var
      FClient     : TFClient;
    
    implementation
    
    {$R *.dfm}
    
    // ... listening port: GUEST CLIENT
    const
      GUEST_PORT = 20010;
    
    // *****************************************************************************
    //   EVENT : onShow()
    //           ON SHOW FORM
    // *****************************************************************************
    procedure TFClient.FormShow(Sender: TObject);
    begin
    
      // ... INITAILIZE
    
      // ... message to send
      messageToSend.Clear;
      messageToSend.Enabled     := false;
    
      // ... log
      messagesLog.Clear;
    
      // ... buttons
      btn_connect.Enabled       := true;
      btn_disconnect.Enabled    := false;
      btn_send.Enabled          := false;
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : btn_connectClick()
    //           CLICK ON CONNECT BUTTON
    // *****************************************************************************
    procedure TFClient.btn_connectClick(Sender: TObject);
    begin
      btn_connect.Enabled := false;
    
      // ... try to connect to Server
      try
        IdTCPClient.Connect;
      except
        on E: Exception do begin
          Log('CLIENT', 'CONNECTION ERROR! ' + E.Message);
          btn_connect.Enabled := true;
        end;
      end;
    
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : btn_disconnectClick()
    //           CLICK ON DISCONNECT BUTTON
    // *****************************************************************************
    procedure TFClient.btn_disconnectClick(Sender: TObject);
    begin
      btn_disconnect.Enabled := false;
    
      // ... disconnect from Server
      IdTCPClient.Disconnect;
    
      // ... set buttons
      btn_connect.Enabled       := true;
      btn_send.Enabled          := false;
    
      // ... message to send
      messageToSend.Enabled     := false;
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onConnected()
    //           OCCURS WHEN CLIENT IS CONNECTED
    // *****************************************************************************
    procedure TFClient.IdTCPClientConnected(Sender: TObject);
    begin
      // ... messages log
      Log('CLIENT', 'CONNECTED!');
    
      // ... after connection is ok, run the Thread ... waiting messages 
      //     from server
      IdThreadComponent.Active := true;
    
      // ... set buttons
      btn_disconnect.Enabled    := true;
      btn_send.Enabled          := true;
    
      // ... enable message to send
      messageToSend.Enabled     := true;
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onDisconnected()
    //           OCCURS WHEN CLIENT IS DISCONNECTED
    // *****************************************************************************
    procedure TFClient.IdTCPClientDisconnected(Sender: TObject);
    begin
      // ... message log
      Log('CLIENT', 'DISCONNECTED!');
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : btn_sendClick()
    //           CLICK ON SEND BUTTON
    // *****************************************************************************
    procedure TFClient.btn_sendClick(Sender: TObject);
    begin
      // ... send message to Server
      IdTCPClient.IOHandler.WriteLn(messageToSend.Text);
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   EVENT : onRun()
    //           OCCURS WHEN THE SERVER SEND A MESSAGE TO CLIENT
    // *****************************************************************************
    procedure TFClient.IdThreadComponentRun(Sender: TIdThreadComponent);
    var
      msgFromServer : string;
    begin
      // ... read message from server
      msgFromServer := IdTCPClient.IOHandler.ReadLn();
    
      // ... messages log
      Log('SERVER', msgFromServer);
    end;
    // .............................................................................
    
    
    // *****************************************************************************
    //   FUNCTION : Log()
    //              LOGS A MESSAGE TO THE UI
    // *****************************************************************************
    procedure TFClient.Log(p_who, p_message: string);
    begin
      TThread.Queue(nil,
        procedure
        begin
          MessagesLog.Lines.Add('[' + p_who + '] - ' + FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ' + p_message);
        end
      );
    end;
    // .............................................................................
    
    end.