TIpTCPServer and Client in one application

Question

I make an application where the client and the server are in the same program. I use Delphi XE7 and components TIpTCPServer / ... Client. But when I try to close the server with the client connected (in the same window), the program stops responding. Perhaps this is something related to multithreading. How to implement a program with a client and server in one application and is this the right approach?

procedure TfrmMain.startClick(Sender: TObject);
begin
  if (server.active) then stopServer()
  else startServer();
end;

procedure TfrmMain.startServer();
var
  binding: TIdSocketHandle;
begin
  server.bindings.clear();

  try
    server.defaultPort := strToInt(port.text);
    binding := server.bindings.add();
    binding.ip := ip;
    binding.port := strToInt(port.text);

    server.active := true;

    if (server.active) then begin
      addToLog('Server started');
      start.caption := 'Stop';
    end;
  except on e: exception do
    addToLog('Error: ' + e.message + '.');
  end;
end;

procedure TfrmMain.stopServer();
begin
  server.active := false;
  server.bindings.clear();

  if (not(server.active)) then begin
    addToLog('Server stopped');
    start.caption := 'Start';
  end
  else addToLog('Server shutdown error.');
end;

procedure TfrmMain.serverConnect(AContext: TIdContext);
var
  i: integer;
begin
  addToLog('New client: ' + aContext.connection.socket.binding.peerIP + '.');

  clients.clear();
  for i := 0 to server.contexts.lockList.count - 1 do begin
    with TIdContext(server.contexts.lockList[i]) do
      clients.items.add(connection.socket.binding.peerIP);
  end;
  server.contexts.unlockList();
end;

procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
  addToLog('Client ' + aContext.connection.socket.binding.peerIP + ' disconnected from the server.');
end;

procedure TfrmMain.clientConnected(Sender: TObject);
begin
  addToConsole('You connected to server successfully.');
end;

procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
  addToConsole('The connection to the server was interrupted.');
end;

and connection code:

client.host := ip;

try
  client.connect();
except on e: exception do
  addToConsole('Error: ' + e.message);
end;

Answer 1

I see a number of issues with this code.

• How are addToLog() and addToConsole() implemented? Are they thread-safe? Remember that TIdTCPServer is a multi-threaded component, its events are fired in the context of worker threads, not the main UI thread, so any access to the UI, shared variables, etc must be synchronized.

• What is clients? Is it is a UI control? You need to sync access to it so you don't corrupt its content when multiple threads try to access it at the same time.

• Your use of the TIdTCPServer.Contexts property is not adequately protected from exceptions. You need a try..finally block so you can call Contexts.UnlockList() safely.

• More importantly, you are calling Contexts.LockList() too many times in your serverConnect() loop (this is the root cause of your problem). LockList() returns a TIdContextList object. Inside your loop, you should be accessing that list's Items[] property instead of calling LockList() again. Because you do not have a matching UnlockList() for each LockList(), once a client connects to your server, the Contexts list becomes deadlocked, and can no longer be accessed once serverConnect() exits, which includes when clients connect/disconnect, and during TIdTCPServer shutdown (such as in your case).

• serverDisconnect() is not removing any items from clients. serverConnect() should not be resetting clients at all. It should add only the calling TIdContext to clients, and then serverDisconnect() should remove that same TIdContext from clients later.

With that said, try something more like this:

procedure TfrmMain.addToConsole(const AMsg: string);
begin
  TThread.Queue(nil,
    procedure
    begin
      // add AMsg to console ...
    end
  );
end;

procedure TfrmMain.addToLog(const AMsg: string);
begin
  TThread.Queue(nil,
    procedure
    begin
      // add AMsg to log ...
    end
  );
end;

procedure TfrmMain.startClick(Sender: TObject);
begin
  if server.Active then
    stopServer()
  else
    startServer();
end;

procedure TfrmMain.startServer();
var
  binding: TIdSocketHandle;
begin
  server.Bindings.Clear();

  try
    server.DefaultPort := StrToInt(port.Text);
    binding := server.Bindings.Add();
    binding.IP := ip;
    binding.Port := StrToInt(port.Text);

    server.Active := True;

    addToLog('Server started');
    start.Caption := 'Stop';
  except
    on e: Exception do
      addToLog('Error: ' + e.message + '.');
  end;
end;

procedure TfrmMain.stopServer();
begin
  try
    server.Active := False;
    server.Bindings.Clear();

    addToLog('Server stopped');
    start.Caption := 'Start';
  except
    on e: Exception do
      addToLog('Server shutdown error.');
  end;
end;

procedure TfrmMain.serverConnect(AContext: TIdContext);
var
  PeerIP: string;
begin
  PeerIP := AContext.Binding.PeerIP;
  addToLog('New client: ' + PeerIP + '.');

  TThread.Queue(nil,
    procedure
    {
    var
      i: integer;
      list: TIdContextList;
    }
    begin
      {
      clients.clear();
      list := server.Contexts.LockList;
      try
        for i := 0 to list.count - 1 do begin
          clients.Items.Add(TIdContext(list[i]).Binding.PeerIP);
        end;
      finally
        list.UnlockList();
      end;
      }

      // I'm assuming clients is a UI control whose Items property
      // is a TStrings object.  If not, adjust this code as needed...
      clients.Items.AddObject(PeerIP, AContext);
    end;
  );
end;

procedure TfrmMain.serverDisconnect(AContext: TIdContext);
begin
  addToLog('Client ' + AContext.Binding.PeerIP + ' disconnected from the server.');

  TThread.Queue(nil,
    procedure
    var
      i: Integer;
    begin
      // I'm assuming clients is a UI control whose Items property
      // is a TStrings object.  If not, adjust this code as needed...
      i := clients.Items.IndexOfObject(AContext);
      if i <> -1 then
        clients.Items.Delete(i);
    end
  );
end;

procedure TfrmMain.clientConnected(Sender: TObject);
begin
  addToConsole('You connected to server successfully.');
end;

procedure TfrmMain.clientDisconnected(Sender: TObject);
begin
  addToConsole('The connection to the server was interrupted.');
end;