i already tried use TIdTcpServer many times, and i always have the same issue.
after some time working (receiving connections) he stop receive new connections and need restart him for back work.
the code who i use now it's very simply, but the problem still happening. and i don't know what do more, i'm almost purchasing a connection framework for see if solve the problem.
procedure TForm1.ClientStateUpdated(Client: TClient; Texto: String);
var
PeerIP, HostName: string;
begin
PeerIP := Client.IP;
HostName := Client.HWID;
TThread.Queue(nil,
procedure
begin
if ((PeerIP <> '') and (HostName <> '')) then Memo2.Lines.Add(Format(Texto, [TimeToStr(Now), PeerIP, HostName]));
end);
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
Conexao : TClient;
Retorno : TArray<String>;
Query : TFDQuery;
Libera : Boolean;
IPEX : Boolean;
begin
Libera := True;
IPEX := True;
Conexao := TClient(AContext);
Retorno := AContext.Connection.IOHandler.ReadLn(LF, 5000).Split(['#']);
if Length(Retorno) = 0 then
begin
AContext.Connection.Disconnect;
Exit;
end;
if Retorno[0] = 'cmdPing' then Retorno[1] := Retorno[2];
Conexao.IP := AContext.Connection.Socket.Binding.PeerIP;
Conexao.HWID := Retorno[1];
Conexao.Connected := Now;
Conexao.Ping := Ticks;
ClientStateUpdated(Conexao, "%s %s %s");
Conexao.Connection.IOHandler.WriteLn('cmdContinue');
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
begin
ClientStateUpdated(TClient(AContext), RetornaTraducao(32));
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Conexao : TClient;
Retorno : TArray<String>;
begin
Conexao := TClient(AContext);
Retorno := AContext.Connection.IOHandler.ReadLn.Split(['#']);
end;
Others declarations:
type
TClient = class(TIdServerContext)
private
FCriticalSection : TCriticalSection;
public
IP : String;
HWID : String;
Connected : TDateTime;
Ping : Cardinal;
Queue : TIdThreadSafeStringList;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
procedure Lock;
procedure Unlock;
end;
constructor TClient.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
FCriticalSection := TCriticalSection.Create;
Queue := TIdThreadSafeStringList.Create;
end;
destructor TClient.Destroy;
begin
Queue.Free;
FreeAndNil(FCriticalSection);
inherited;
end;
procedure TClient.Lock;
begin
FCriticalSection.Enter;
end;
procedure TClient.Unlock;
begin
FCriticalSection.Leave;
end;
The strange thing is, if i create an application who connect/disconnect and run it for MANY hours application works fine, but when i release it for public the problem come.
i don't use IdSchedulerOfThreadDefault1 / IdSchedulerOfThreadPool1
Related
I am writing a client / server application. There is one server and several clients.
When connecting a client, the task is to add its IP address to the ListBox, and when disconnecting the client, remove it from the ListBox. Then exchange messages between the client and server.
Three questions arose: when a client connects, its IP address is added to the ListBox, but when disconnected, it is not deleted from there, here is the code:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
ListLink : Integer;
Thread : Pointer;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient.Create;
Client.DNS := AContext.Connection.Socket.Binding.PeerIP;
Client.ListLink := ListBox1.Items.Count;
Client.Thread := AContext;
ListBox1.Items.Add(Client.DNS);
AContext.Data := Client;
Clients.Add(Client);
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
sleep(2000);
Client :=Pointer (AContext.Data);
Clients.Delete(Client.ListLink);
ListBox1.Items.Delete(ListBox1.Items.IndexOf(Client.DNS));
Client.Free;
AContext.Data := nil;
end;
The second question, when exchanging messages, the letters in Cyrillic are given as "???", all Google went through it and it was not possible to find an error.
And the third question, on the client is a timer that listens to messages from the server, when the timer is turned on, the client application hangs tight, putting all this into the stream is the same trouble, the code:
if not IdTCPClient1.Connected then
Exit;
s := IdTCPClient1.Socket.ReadLn;
if s <> '' then
Label1.Text := s;
I see quite a few problems with your code.
On the server side, you need to get rid of the TSimpleClient.ListLink field. You are misusing it, causing bad behaviors in your code since you don't keep it updated as clients are added/removed. Think of what happens when you have 2 clients connected, where ListLink is 0 and 1 respectively, and then the 1st client disconnects. The ListLink for the 2nd client will become invalid since you don't decrement it from 1 to 0.
Also TIdTCPServer is a multi-threaded component, its events are fired in the context of worker threads, but your event handler code is not thread-safe. You MUST synchronize with the main UI thread when accessing UI controls from worker threads, and you MUST protect your Clients list from concurrent access across thread boundaries. In this case, you don't really need your own Clients list to begin with as TIdTCPServer has its own thread-safe Contexts list that you can use to access the connected clients.
You are also not handling Unicode at all. By default, Indy's default byte encoding for Unicode strings is US-ASCII, which is why you are getting ? for non-ASCII characters. You can use the IOHandler's DefStringEncoding property to set a different byte encoding, such as IndyTextEncoding_UTF8 (if you are using Delphi 2007 or earlier, you might need to also use the IOHandler's DefAnsiEncoding property to specify how your ANSI strings are converted to/from Unicode. By default, it is set to IndyTextEncoding_OSDefault).
Try something more like this:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
Thread : Pointer;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create;
begin
inherited;
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
TIdContext(Thread).Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient.Create;
Client.DNS := PeerIP;
Client.Thread := AContext;
AContext.Data := Client;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
try
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
finally
{ The anonymous procedure being passed to TThread.Queue() above captures
the Client variable itself, not its value. On ARC platforms, we need to
prevent Free() setting the variable to nil before it can be passed to
IndexOfObject(), and also because IndexOfObject() expects a live object
anyway. ARC will free the object when the anonymous procedure exits. On
non-ARC platforms, it is OK to Free() the object here, the variable will
not change value, and IndexOfObject() does not need a live object... }
{$IFNDEF AUTOREFCOUNT}
Client.Free;
{$ENDIF}
AContext.Data := nil;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client.Thread)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
Alternatively, you can derive TSimpleClient from TIdServerContext and get rid of the Thread field altogether:
type
TSimpleClient = class(TIdServerContext)
DNS,
Name : String;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
Self.Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
IdTCPServer1.ContextClass := TSimpleClient;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient(AContext);
Client.DNS := PeerIP;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext);
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
On the client side, you are reading from the socket in the main UI thread, but Indy uses blocking sockets, and so its reading methods will block the calling thread until the requested data arrives. DON'T block the main UI thread! Read only if there is actually something available to read, or else move the reading into a separate worker thread. For example:
IdTCPClient1.Connect;
IdTCPClient1.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
...
IdTCPClient1.Disconnect;
...
procedure TForm1.Timer1Timer(Sender: TObject);
var
s: string;
begin
if IdTCPClient1.Connected and (not IdTCPClient1.IOHandler.InputBufferIsEmpty) then
begin
s := IdTCPClient1.IOHandler.ReadLn;
if s <> '' then
Label1.Text := s;
end;
end;
Alternatively:
type
TReadingThread = class(TThread)
protected
procedure Execute; override;
end;
procedure TReadingThread.Execute;
var
s: String;
begin
while not Terminated do
begin
s := Form1.IdTCPClient1.IOHandler.ReadLn;
if s <> '' then
begin
TThread.Queue(nil,
procedure
begin
Form1.Label1.Text := s;
end
);
end;
end;
end;
...
var
ReadingThread: TReadingThread = nil;
...
IdTCPClient1.Connect;
IdTCPClient1.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
ReadingThread := TReadingThread.Create(False);
...
ReadingThread.Terminate;
try
IdTCPClient1.Disconnect;
finally
ReadingThread.WaitFor;
ReadingThread.Free;
end;
Thank you so much Remy, your answer really helped me sort out my problem. I targeted Windows and Android platforms. I fixed your code a little and it worked for me:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
Thread : Pointer;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create;
begin
inherited;
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
Client: TSimpleClient;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
Client.FlushMsgs;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
TIdContext(Thread).Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient.Create;
Client.DNS := PeerIP;
Client.Thread := AContext;
AContext.Data := Client;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
try
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
finally
{ The anonymous procedure being passed to TThread.Queue() above captures
the Client variable itself, not its value. On ARC platforms, we need to
prevent Free() setting the variable to nil before it can be passed to
IndexOfObject(), and also because IndexOfObject() expects a live object
anyway. ARC will free the object when the anonymous procedure exits. On
non-ARC platforms, it is OK to Free() the object here, the variable will
not change value, and IndexOfObject() does not need a live object... }
{$IFNDEF AUTOREFCOUNT}
Client.Free;
{$ENDIF}
AContext.Data := nil;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client.Thread)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
I added a call to the FlushMsgs method from the TSimpleClient.Queue procedure and messages started to be sent, the list of clients is updated every time clients are connected and disconnected, and the server stopped hanging. Thanks again Remy, you helped a lot to speed up the development, golden man.
I'm having a problem. I created a TIdTCPServer but I need to prevent false/unknown connections.
I tried this:
procedure Wait(millisecs: Integer);
var
tick: dword;
AnEvent: THandle;
begin
AnEvent := CreateEvent(nil, False, False, nil);
try
tick := GetTickCount + dword(millisecs);
while (millisecs > 0) and (MsgWaitForMultipleObjects(1, AnEvent, False, millisecs, QS_ALLINPUT) <> WAIT_TIMEOUT) do begin
Application.ProcessMessages;
if Application.Terminated then Exit;
millisecs := tick - GetTickcount;
end;
finally
CloseHandle(AnEvent);
end;
end;
procedure CheckCon(Con: Pointer);
begin
Wait(5000);
if TClient(Con).HWID = '' then TClient(Con).Connection.Disconnect;
EndThread(0);
end;
constructor TClient.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
var
ThreadId : Cardinal;
begin
inherited Create(AConnection, AYarn, AList);
FCriticalSection := TCriticalSection.Create;
Queue := TIdThreadSafeStringList.Create;
BeginThread(nil, 0, #CheckCon, Self, 0, ThreadId);
end;
OnConnect event code:
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
Conexao : TClient;
Retorno : TArray<String>;
Query : TFDQuery;
Libera : Boolean;
IPEX : Boolean;
begin
Libera := True;
IPEX := True;
Conexao := TClient(AContext);
Retorno := AContext.Connection.IOHandler.ReadLn.Split(['#']);
if Length(Retorno) = 0 then
begin
AContext.Connection.Disconnect;
Exit;
end;
Conexao.IP := AContext.Connection.Socket.Binding.PeerIP;
Conexao.HWID := Retorno[1];
Conexao.Connected := Now;
Conexao.Ping := Ticks;
ClientStateUpdated(Conexao, RetornaTraducao(40));
TThread.Queue(nil,
procedure
begin
Memo2.Lines.Add(Format(RetornaTraducao(36), [TimeToStr(Now), Conexao.IP, Conexao.HWID]));
end);
end;
If I test creating a low number of unknown clients, it works good, but if I flood it with MANY connections, the application crashes. I need something like this to prevent unknown connections in my TIdTCPServer.
I tried calling
Memo2.Lines.Add(Format('[%s]', [AContext.Connection.IOHandler.ReadLn]));
in IdTCPServer1Connect to determine if the connection was my application, but if the client only connects and doesn't send anything, the line doesn't execute.
Starting a worker thread inside of TClient's constructor is completely unnecessary (the TClient object is already run in a thread created by the server). You can simply set a 5 second timeout on the ReadLn() call itself and be done with it.
Also, TIdTCPServer is a multi-threaded component, its events are fired in the context of worker threads, so access to UI controls like Memo2 MUST by synchronized with the UI thread or else bad things happen.
Try something more like this:
constructor TClient.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
FCriticalSection := TCriticalSection.Create;
Queue := TIdThreadSafeStringList.Create;
end;
...
// code adapted from my reply to your previous question:
//
// https://stackoverflow.com/a/58479489/65863
//
// tweak as needed...
//
procedure TForm1.ClientStateUpdated(Client: TClient; const Msg: string);
var
IP, HWID: string;
begin
IP := Client.IP;
HWID := Client.HWID;
TThread.Queue(nil,
procedure
begin
Memo2.Lines.Add(Format(RetornaTraducao(36), [TimeToStr(Now), IP, HWID, Msg]));
end
);
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
Conexao : TClient;
Retorno : TArray<String>;
begin
Conexao := TClient(AContext);
Retorno := AContext.Connection.IOHandler.ReadLn(LF, 5000).Split(['#']);
if (Length(Retorno) < 2) or (Retorno[1] = '') then
begin
AContext.Connection.Disconnect;
Exit;
end;
Conexao.IP := AContext.Binding.PeerIP;
Conexao.HWID := Retorno[1];
Conexao.Connected := Now;
Conexao.Ping := Ticks;
ClientStateUpdated(Conexao, RetornaTraducao(40){'connect'});
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Conexao : TClient;
begin
Conexao := TClient(AContext);
if Conexao.Connected <> 0 then
ClientStateUpdated(Conexao, RetornaTraducao(...){'disconnect'});
end;
After some time my client thread stops receiving/sending commands from/to TIdTcpServer.
Here is the client side thread I copied from an example from Remy:
Tested locally and it doesn't happen, only on a running environment the error occurs...
type
TDataEvent = procedure(const LBuffer: TIdBytes) of object;
TReadingThread = class(TThread)
private
FClient : TIdTCPClient;
FData : TIdBytes;
FOnData : TDataEvent;
procedure DataReceived;
protected
procedure Execute; override;
public
constructor Create(AClient: TIdTCPClient); reintroduce;
property OnData: TDataEvent read FOnData write FOnData;
end;
constructor TReadingThread.Create(AClient: TIdTCPClient);
begin
inherited Create(True);
FClient := AClient;
end;
procedure TReadingThread.Execute;
begin
while not Terminated do
begin
Form1.Cliente.IOHandler.ReadBytes(FData, szProtocol, False);
if (FData <> nil) and Assigned(FOnData) then Synchronize(DataReceived);
end;
end;
procedure TReadingThread.DataReceived;
begin
if Assigned(FOnData) then FOnData(FData);
end;
procedure TForm1.DataReceived(const LBuffer: TIdBytes);
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LDataSize : Integer;
LProtocol : TProtocol;
LBuffer2 : TBytes;
LProtocol2 : TProtocol;
begin
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdHWID:
begin
HWID := LProtocol.Sender.HWID;
end;
cmdPing:
begin
InitProtocol(LProtocol2);
LProtocol2.Command := cmdPing;
LProtocol2.Sender.PBack := GetTickCount;
LBuffer2 := ProtocolToBytes(LProtocol2);
Form1.Cliente.IOHandler.Write(PTIdBytes(#LBuffer2)^);
ClearBuffer(LBuffer2);
end;
end;
end;
For a while all works perfectly, but after some time, the client side stops receiving/sending. The connection to the server is seems to be still open.
function to find connection by ip:
list := IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count - 1 do
begin
ctx := TIdContext(list[i]);
if ctx.Binding.PeerIP = Edit9.Text then
begin
TLog.AddMsg('IP FOUND');
Achou := True;
Cliente := TClientContext(ctx);
SerialCn := Cliente.Client.HWID;
IpCn := Cliente.Client.IP;
break;
end;
end;
finally
IdTCPServer1.Contexts.UnlockList;
end;
I would like to implement a simple watchdog timer in Delphi XE 7 with two use cases:
• Watchdog ensures that a operation doesn't execute longer than x seconds
• Watchdog ensures that when errors occur then message exception will be stored in log file
Could you please suggest me any solution?
Here is my solution. I'm not sure that is a proper, but its works. I crated a new thread:
type
// will store all running processes
TProcessRecord = record
Handle: THandle;
DateTimeBegin, DateTimeTerminate: TDateTime;
end;
TWatchDogTimerThread = class(TThread)
private
FItems: TList<TProcessRecord>;
FItemsCS: TCriticalSection;
class var FInstance: TWatchDogTimerThread;
function IsProcessRunning(const AItem: TProcessRecord): Boolean;
function IsProcessTimedOut(const AItem: TProcessRecord): Boolean;
procedure InternalKillProcess(const AItem: TProcessRecord);
protected
constructor Create;
procedure Execute; override;
public
class function Instance: TWatchDogTimerThread;
destructor Destroy; override;
procedure AddItem(AProcess: THandle; ADateStart: TDateTime; ATimeOutMS: Cardinal);
end;
const
csPocessThreadLatencyTimeMs = 500;
And here is an implementation part:
procedure TWatchDogTimerThread.Execute;
var
i: Integer;
begin
while not Terminated do
begin
Sleep(csPocessThreadLatencyTimeMs);
FItemsCS.Enter;
try
i := 0;
while i < FItems.Count do
begin
if not IsProcessRunning(FItems[i]) then
begin
FItems.Delete(i);
end
else if IsProcessTimedOut(FItems[i]) then
begin
InternalKillProcess(FItems[i]);
FItems.Delete(i);
end
else
Inc(i);
end;
finally
FItemsCS.Leave;
end;
end;
end;
procedure TWatchDogTimerThread.AddItem(AProcess: THandle; ADateStart: TDateTime; ATimeOutMS: Cardinal);
var
LItem: TProcessRecord;
begin
LItem.Handle := AProcess;
LItem.DateTimeBegin := ADateStart;
LItem.DateTimeTerminate := IncMilliSecond(ADateStart, ATimeOutMS);
FItemsCS.Enter;
try
FItems.Add(LItem);
finally
FItemsCS.Leave;
end;
end;
constructor TWatchDogTimerThread.Create;
begin
inherited Create(False);
FItems := TList<TProcessRecord>.Create;
FItemsCS := TCriticalSection.Create;
end;
destructor TWatchDogTimerThread.Destroy;
begin
FreeAndNil(FItemsCS);
FItems.Free;
FInstance := nil;
inherited;
end;
class function TWatchDogTimerThread.Instance: TWatchDogTimerThread;
begin
if not Assigned(FInstance) then
FInstance := Create;
Result := FInstance;
end;
procedure TWatchDogTimerThread.InternalKillProcess(const AItem: TProcessRecord);
begin
if AItem.Handle <> 0 then
TerminateProcess(AItem.Handle, 0);
end;
function TWatchDogTimerThread.IsProcessRunning(const AItem: TProcessRecord): Boolean;
var
LPID: DWORD;
begin
LPID := 0;
if AItem.Handle <> 0 then
GetWindowThreadProcessId(AItem.Handle, #LPID);
Result := LPID <> 0;
end;
function TWatchDogTimerThread.IsProcessTimedOut(const AItem: TProcessRecord): Boolean;
begin
Result := (AItem.DateTimeTerminate < Now);// and IsProcessRunning(AItem);
end;
end.
What is the proper way to identify clients if they have the same IP and ports? If they are only connected via LAN, e.g. ip: 198.162.1.1 port: 2015. How do I detect which client has disconnected using its unique ID if they have the same IP?
TClient = class(TIdServerContext)
private
public
PeerIP : String;
procedure SendMessage(cIP, mStr : String);
end;
procedure TClient.SendMessage(cIP, mStr : String);
var
Context: TClient;
List: TList;
I: Integer;
begin
List := Form1.IdTCPServer1.Contexts.LockList;
try
for I := 0 to List.Count-1 do
begin
Context := TClient(List[I]);
if (Context.PeerIP = cIP) then
begin
Connection.IOHandler.WriteLn(mStr);
Break;
end
end;
finally
Form1.IdTCPServer1.Contexts.UnlockList;
end;
end;
I'm only storing the client IP and using it as an ID.
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
begin
with TClient(AContext) do
begin
if AContext.Connection.Connected then
begin
PeerIP := Connection.Socket.Binding.PeerIP;
end;
end;
end;
Maybe like ClientID := Connection.Socket.Binding.Handle;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
begin
//Connection.Socket.Binding.Handle; ??
end;
The PeerIP alone is not unique enough to identify a client. Think of what happens when multiple clients running on one side of a router connect to the same server running on the other side of the router. The clients will have the same PeerIP (the router's IP) from the server's perspective. You need each client's PeerIP and PeerPort together.
TClient = class(TIdServerContext)
public
PeerIP : String;
PeerPort : TIdPort;
procedure SendMessage(cIP: string; cPort: TIdPort; mStr : String);
end;
procedure TClient.SendMessage(cIP: string; cPort: TIdPort; mStr : String);
var
Context: TClient;
List: TList;
I: Integer;
begin
List := Form1.IdTCPServer1.Contexts.LockList;
try
for I := 0 to List.Count-1 do
begin
Context := TClient(List[I]);
if (Context <> Self) and (Context.PeerIP = cIP) and (Context.PeerPort = cPort) then
begin
Context.Connection.IOHandler.WriteLn(mStr);
Break;
end
end;
finally
Form1.IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
with TClient(AContext) do
begin
PeerIP := Connection.Socket.Binding.PeerIP;
PeerPort := Connection.Socket.Binding.PeerPort;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
begin
...
end;
Or simply don't rely on IP/Port at all. Make up your own unique ID, such as requiring each client to login to the server with a UserID.
TClient = class(TIdServerContext)
public
UserID : String;
procedure SendMessage(cUser, mStr : String);
end;
procedure TClient.SendMessage(cUser, mStr : String);
var
Context: TClient;
List: TList;
I: Integer;
begin
List := Form1.IdTCPServer1.Contexts.LockList;
try
for I := 0 to List.Count-1 do
begin
Context := TClient(List[I]);
if (Context <> Self) and (Context.UserID = cUser) then
begin
Context.Connection.IOHandler.WriteLn(mStr);
Break;
end
end;
finally
Form1.IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
with TClient(AContext) do
begin
// this is just for demonstration. Obviously, you
// should implement a real protocol with authentication,
// duplicate login detection, etc...
UserID := Connection.IOHandler.ReadLn;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
begin
...
end;