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;
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 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
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 need to send a string message from IdTCPServer to a specific connected IdTCPClient. In the beginning I was using a Listbox, so I added the hostname to the listbox when client connected and remove when disconnect. At that time, Remy Lebeau give me this tip:
procedure TfrmMain.sendButtonClick(Sender: TObject);
var
Index: Integer;
Ctx: TIdContext;
begin
Index := ListBox.ItemIndex;
if Index = -1 then Exit;
Context := TIdContext(ListBox.Items.Objects[Index]);
// use Context as needed...
end;
But now I am using a Listview, with pre-added hostnames. So I just change the listbox item image status when clients connect or disconnect. Now I am trying something like this:
procedure TfrmMain.TCPServerConnect(AContext: TIdContext);
begin
TThread.Queue(nil,
procedure
var
Host: String;
LItem: TListItem;
begin
Host := UpperCase(GStack.HostByAddress(Ctxt.Binding.PeerIP));
LItem := lvwPCList.FindCaption(0, Host, False, True, False);
if (LItem <> nil) then LItem.Data := AContext.Data;
end
);
end;
And once I linked the Listview Item with the Context data, I am trying to send the message direct to client:
procedure TfrmMain.SendMessage(const Item: TListItem; const Msg: String);
var
Ctx: TIdContext;
begin
if (Trim(Msg) = '') then Exit;
Ctx := TIdContext(Item.Data);
try
Ctx.Connection.IOHandler.WriteLn(Msg);
except
end;
end;
SendMessage(Listview.Selected, 'test');
I can compile this code, but the message never reachs client. Please, what I am doing wrong?
Thanks!
You are assigning the value of the TIdContext.Data property to the TListItem.Data property, but you are casting TListItem.Data to TIdContext when it is not pointing at a TIdContext to begin with.
You should also take into account the condition that a client may have disconnected before you have a chance to update the TListView.
Try something more like this instead:
procedure TfrmMain.TCPServerConnect(AContext: TIdContext);
var
LHost: string;
begin
LHost := UpperCase(GStack.HostByAddress(AContext.Binding.PeerIP));
TThread.Queue(nil,
procedure
var
LItem: TListItem;
begin
LItem := lvwPCList.FindCaption(0, LHost, False, True, False);
if (LItem <> nil) then LItem.Data := AContext;
end
);
end;
procedure TfrmMain.TCPServerDisconnect(AContext: TIdContext);
begin
TThread.Queue(nil,
procedure
var
LItem: TListItem;
begin
LItem := lvwPCList.FindData(0, AContext, True, False);
if (LItem <> nil) then LItem.Data := nil;
end
);
end;
procedure TfrmMain.SendMessage(const Item: TListItem; const Msg: String);
var
Ctx: TIdContext;
List: TIdContextList;
begin
if (Item = nil) then Exit;
Ctx := TIdContext(Item.Data);
if (Ctx = nil) then Exit;
if (Trim(Msg) = '') then Exit;
try
List := TCPServer.Contexts.LockList;
try
if List.IndexOf(Ctx) <> -1 then
Ctx.Connection.IOHandler.WriteLn(Msg);
finally
TCPServer.Contexts.UnlockList;
end;
except
end;
end;
SendMessage(Listview.Selected, 'test');
That being said, depending on how your communication protocol is actually implemented, you probably should not be calling WriteLn() outside of the TIdTCPServer.OnExecute event, otherwise you risk corrupting any data that OnExecute may be writing at the same time that the main thread is trying to write. If this is the case, then you should implement a per-client queue of outbound data any have the OnExecute event send that data when it is safe to do so, eg:
uses
..., IdThreadSafe;
type
TMyContext = class(TIdServerContext)
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
Queue: TIdThreadSafeStringList;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
Queue := TIdThreadSafeStringList.Create;
end;
destructor TMyContext.Destroy;
begin
Queue.Free;
inherited;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
TCPServer.ContextClass := TMyContext;
end;
procedure TfrmMain.TCPServerConnect(AContext: TIdContext);
var
LHost: string;
begin
LHost := UpperCase(GStack.HostByAddress(AContext.Binding.PeerIP));
TThread.Queue(nil,
procedure
var
LItem: TListItem;
begin
LItem := lvwPCList.FindCaption(0, LHost, False, True, False);
if (LItem <> nil) then LItem.Data := AContext;
end
);
end;
procedure TfrmMain.TCPServerDisconnect(AContext: TIdContext);
begin
TThread.Queue(nil,
procedure
var
LItem: TListItem;
begin
LItem := lvwPCList.FindData(0, AContext, True, False);
if (LItem <> nil) then LItem.Data := nil;
end
);
end;
procedure TfrmMain.TCPServerExecute(AContext: TIdContext);
var
Ctx: TMyContext;
Queue: TStringList;
List: TStringList;
begin
...
Ctx := TMyContext(AContext);
List := nil;
try
Queue := Ctx.Queue.Lock;
try
if Queue.Count > 0 then
begin
List := TStringList.Create;
List.Assign(Queue);
Queue.Clear;
end;
finally
Ctx.Queue.Unlock;
end;
if List <> nil then
AContext.Connection.IOHandler.Write(List);
finally
List.Free;
end;
...
end;
procedure TfrmMain.SendMessage(const Item: TListItem; const Msg: String);
var
Ctx: TIdContext;
List: TIdContextList;
begin
if (Item = nil) then Exit;
Ctx := TIdContext(Item.Data);
if (Ctx = nil) then Exit;
if (Trim(Msg) = '') then Exit;
try
List := TCPServer.Contexts.LockList;
try
if List.IndexOf(Ctx) <> -1 then
TMyContext(Ctx).Queue.Add(Msg);
finally
TCPServer.Contexts.UnlockList;
end;
except
end;
end;
In your listbox code you appear to be storing TIdContext references in your item "object" slots:
Context := TIdContext(ListBox.Items.Objects[Index]);
But in your listview code you are storing the Data member of a TIdContext, which you are then incorrectly casting as a TIdContext in your SendMessage() method:
// In TCPServerConnect():
if (LItem <> nil) then LItem.Data := AContext.Data;
...
// In SendMessage():
Ctx := TIdContext(Item.Data); // But Item.Data doesn't hold a TIdContext!!!
For direct equivalence with your listbox code, that first line in your TCPServerConnect method should be:
if (LItem <> nil) then LItem.Data := AContext;
Before I explain my problem, I'm sorry for my bad english.
Okay, here my problem. when my Indy server sends bitmap frame to client, always appeared warning like this :
"EAccessViolation at address 004DD42A..."
And error syntax blue highlighted on this :
Athread.Connection.WriteInteger(MemoryStream.Size);
here my source code :
SERVER
procedure TFormHome.TCPServerConnect(AThread: TIdPeerThread);
var
NewClient: PClient;
begin
GetMem(NewClient, SizeOf(TClient));
NewClient.PeerIP := AThread.Connection.Socket.Binding.PeerIP;
NewClient.HostName := GStack.WSGetHostByAddr(NewClient.PeerIP);
NewClient.Connected := Now;
NewClient.LastAction := NewClient.Connected;
NewClient.Thread := AThread;
AThread.Data := TObject(NewClient);
try
Clients.LockList.Add(NewClient);
finally
Clients.UnlockList;
end;
procedure TFormHome.TCPServerExecute(AThread: TIdPeerThread);
var
pesan:string;
begin
pesan:=Athread.Connection.ReadLn;
if pesan = 'video' then
begin
Athread.Connection.WriteLn('send');
Timer1.Enabled:=true;
FormStream.Show;
Athread.Connection.WriteInteger(MemoryStream.Size);
Athread.Connection.OpenWriteBuffer;
Athread.Connection.WriteStream(MemoryStream);
AThread.Connection.CloseWriteBuffer;
FreeAndNil(MemoryStream);
FormStream.Image1.Picture.Bitmap.Free;
end;
procedure TFormHome.Timer1Timer(Sender: TObject);
begin
pic := TBitmap.Create;
MemoryStream:=TMemoryStream.Create;
VideoGrabber.GetBitmap(FormStream.image1.Picture.Bitmap);
pic := FormStream.Image1.Picture.Bitmap;
pic.SaveToStream(MemoryStream);
//Pic.Free;
//FreeAndNil(Pic);
end;
CLIENT
procedure TFormClient.TCPClientConnected(Sender: TObject);
var
pesan : string;
begin
IncomingMessages.Lines.Insert(0,'Connected to Server');
TCPClient.WriteLn('video');
pesan := TCPClient.ReadLn;
if pesan = 'send' then Timer1.Enabled:=true;
end;
procedure TFormClient.Timer1Timer(Sender: TObject);
var
Size : integer;
ReadStream : TMemoryStream;
begin
ReadStream := TMemoryStream.Create;
Size := TCPClient.ReadInteger;
TCPClient.ReadStream(ReadStream,Size,True);
Image1.Picture.Bitmap.LoadFromStream(ReadStream);
Image1.Picture.Bitmap.Free;
FreeAndNil(ReadStream);
end;
what's wrong witha my code? i need your help.
Thank you before.. ^^
You are trying to send the TMemoryStream before it has even been created. You can't use TTimer or TForm in a worker thread (which OnExecute is called in). Even if you could, when TTimer is enabled, its OnTimer event is not triggered immediately, but your code is expecting it to be.
You need to re-write your code to delegate all UI work to the main thread, where it belongs. Try something more like this:
Server:
Uses
..., IdSync;
type
TVideoStartNotify = class(TIdNotify)
protected
procedure DoNotify; override;
public
Thread: TIdPeerThread;
end;
procedure TFormHome.TCPServerDisconnect(AThread: TIdPeerThread);
begin
TIdNotify.NotifyMethod(VideoStop);
end;
procedure TFormHome.TCPServerExecute(AThread: TIdPeerThread);
var
pesan: string;
begin
pesan := AThread.Connection.ReadLn;
if pesan = 'videostart' then
begin
AThread.Connection.WriteLn('send');
with TVideoStartNotify.Create do
begin
Thread := AThread;
Notify;
end;
end
else if pesan = 'videostop' then
begin
AThread.Connection.WriteLn('stop');
TIdNotify.NotifyMethod(VideoStop);
end;
end;
procedure TVideoStartNotify.DoNotify;
begin
FormHome.VideoStart(Thread);
end;
procedure TFormHome.VideoStart(AThread: TIdPeerThread);
begin
ThreadToSendTo := AThread;
Timer1.Enabled := true;
FormStream.Show;
end;
procedure TFormHome.VideoStop;
begin
ThreadToSendTo := nil;
Timer1.Enabled := false;
FormStream.Hide;
end;
procedure TFormHome.Timer1Timer(Sender: TObject);
var
pic: TBitmap;
MemoryStream: TMemoryStream;
begin
if ThreadToSendTo = nil then
begin
Timer1.Enabled := False;
Exit;
end;
pic := FormStream.Image1.Picture.Bitmap;
try
MemoryStream := TMemoryStream.Create;
try
VideoGrabber.GetBitmap(pic);
pic.SaveToStream(MemoryStream);
try
ThreadToSendTo.Connection.WriteStream(MemoryStream, True, True);
except
ThreadToSendTo := nil;
Timer1.Enabled := False;
end;
finally
MemoryStream.Free;
end;
finally
FormStream.Image1.Picture := nil;
end;
end;
Client:
Uses
..., IdSync;
type
TLogNotify = class(TIdNotify)
protected
procedure DoNotify; override;
public
Msg: String;
end;
procedure TLogNotify.DoNotify;
begin
FormClient.LogMsg(Msg);
end;
procedure TFormClient.Button1Click(Sender: TObject);
begin
TCPClient.Connect;
end;
procedure TFormClient.Button2Click(Sender: TObject);
begin
try
TCPClient.WriteLn('videostop');
finally
TCPClient.Disconnect;
end;
end;
procedure TFormClient.TCPClientConnected(Sender: TObject);
var
pesan : string;
begin
with TLogNotify.Create do
begin
Msg := 'Connected to Server';
Notify;
end;
TCPClient.WriteLn('videostart');
pesan := TCPClient.ReadLn;
if pesan = 'send' then
TIdNotify.NotifyMethod(VideoStart);
end;
procedure TFormClient.TCPClientDisconnected(Sender: TObject);
begin
with TLogNotify.Create do
begin
Msg := 'Disconnected from Server';
Notify;
end;
TIdNotify.NotifyMethod(VideoStop);
end;
procedure TFormClient.LogMsg(const AMsg: string);
begin
IncomingMessages.Lines.Insert(0, AMsg);
end;
procedure TFormClient.VideoStart;
begin
Timer1.Enabled := true;
end;
procedure TFormClient.VideoStop;
begin
Timer1.Enabled := false;
Image1.Picture := nil;
end;
procedure TFormClient.Timer1Timer(Sender: TObject);
var
ReadStream : TMemoryStream;
begin
ReadStream := TMemoryStream.Create;
try
TCPClient.ReadStream(ReadStream, -1, False);
ReadStream.Position := 0;
Image1.Picture.Bitmap.LoadFromStream(ReadStream);
finally
ReadStream.Free;
end;
end;