TIpTCPServer and Client in one application - delphi

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;