delphi tcp server on multi port hanged on close - delphi

i used a multi port tcp server to receive some connections
like this
procedure TForm2.IdTCPServer1Execute(AContext: TIdContext);
var
aByte: Byte;
i,j , tmBodyFrameLength:integer;
myThread : tthread;
begin
if not Assigned( allOfflineStringList ) then
begin
allOfflineStringList := TStringlist.Create;
end;
allOfflineStringList.Clear;
case AContext.Binding.Port of
55000: begin {offline and image}
AContext.Connection.IOHandler.ReadBytes(data, 1099, False);
rowFrame :='';
for I := 0 to length(data)-1 do
begin
rowFrame := rowFrame + (data[i].ToHexString);
end;
newFrame := copy( rowFrame , 9 , maxInt );
allOfflineStringList.Append( newFrame );
TThread.Synchronize (TThread.CurrentThread,
procedure ()
begin
Label985.caption := 'Offline : ' + allOfflineStringList.Count.ToString ;
//Memo14.Lines.Add( datetimetostr(now) +':'+ newFrame );
form2.AbLED601.Tag := DateTimeToUnix(now);
form2.AbLED601.Checked := true;
end);
end;
55001: begin {tm online}
repeat
aByte := AContext.Connection.IOHandler.ReadByte;
if aByte=$C0 then
begin
SDRtmOnlineRowFrame2 := SDRtmOnlineRowFrame;
SDRtmOnlineRowFrame := '';
TThread.Synchronize (TThread.CurrentThread,
procedure ()
begin
form2.Memo14.Lines.Add('tm:'+ SDRtmOnlineRowFrame2 );
end);
end
else
begin
SDRtmOnlineRowFrame := SDRtmOnlineRowFrame + aByte.ToHexString;
end;
until true;
end;
55003: begin {beacon online}
repeat
aByte := AContext.Connection.IOHandler.ReadByte;
if aByte=$C0 then
begin
SDRtmOnlineBeaconRowFrame2 := SDRtmOnlineBeaconRowFrame;
SDRtmOnlineBeaconRowFrame := '';
TThread.Synchronize (TThread.CurrentThread,
procedure ()
begin
form2.Memo14.Lines.Add('beacon:'+ SDRtmOnlineBeaconRowFrame2 );
end);
end
else
begin
SDRtmOnlineBeaconRowFrame := SDRtmOnlineBeaconRowFrame + aByte.ToHexString;
end;
until true;
end;
end;
end;
every thing working good
but when data is receiving if i close the connection
app will hange and dont responding any more!
enable and disable is like this:
procedure TForm2.CheckBox6Click(Sender: TObject);
var
ic:integer;
allIpList : TStringList;
begin
AbLED412.Checked := CheckBox6.Checked;
if CheckBox6.Checked=true then
begin
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55000;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55001;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55003;
end;
IdTCPServer1.Active := True;
IdTCPServer1.StartListening;
TIdStack.IncUsage;
try
allIpList := TStringList.Create;
GStack.AddLocalAddressesToList( allIpList );
memo14.lines.clear;
for ic := 0 to allIpList.Count-1 do
begin
memo14.lines.Add('Create tcp connection on ip : '+allIpList[ic]+' and port : 55000');
memo14.lines.Add('Create tcp connection on ip : '+allIpList[ic]+' and port : 55001');
memo14.lines.Add('Create tcp connection on ip : '+allIpList[ic]+' and port : 55003');
end;
finally
TIdStack.DecUsage;
end;
end
else
begin
IdTCPServer1.StopListening;
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
memo14.lines.clear;
end;
end;
also when data is receiving if i close the app it hanged again
but when sender disconnected closing the app dont make any problem
how can i fix this?

Your TIdTCPServer.OnExecute handler is using multiple variables in a thread-unsafe manner. You are not protecting them from multiple threads accessing them at the same time, thus causing race conditions on their data.
But, more importantly, your use of TThread.Synchronize() is a common cause of deadlock for TIdTCPServer because it is a multi-threaded component. Its OnConnect, OnDisconnect, OnExecute, and OnError events are called in the context of client worker threads, not in the main UI thread. TThread.Synchronize() blocks the calling thread until the main UI thread processes the request. Deactivating TIdTCPServer terminates all running client threads and waits for them to fully terminate. So, if you call TThread.Synchronize() in a client thread while the main UI thread is blocked deactivating the server, then the client thread is waiting on the main UI thread while the main UI thread is waiting on the client thread - deadlock!
You have a few options to solve this:
avoid calling TThread.Synchronize() while deactivating the server. Easier said than done though, as you might already be in a pending TThread.Synchronize() by the time you decide to deactivate TIdTCPServer. And it is a race condition when making the decision whether to call TThread.Synchronize() or not.
deactivate TIdTCPServer in a separate worker thread, leave the main UI thread free to process TThread.Synchronize() and TThread.Queue() requests. If you use a TThread for the deactivation, calling the TThread.WaitFor() method in the main UI thread will process Synchronize()/Queue() requests while it is waiting for the thread to terminate.
Use TThread.Queue() instead of TThread.Synchronize(), especially when performing actions that your client threads don't actually need to wait on, such as UI updates.
On a side note, in your CheckBox6Click():
you should not be calling TIdTCPServer.StartListening() or TIdTCPServer.StopListening() at all. The TIdTCPServer.Active property setter calls them internally for you.
you don't need to call TIdStack.IncUsage() or TIdStack.DecUsage() either, as TIdTCPServer's constructor and destructor call them for you.
you are leaking allIpList as you don't Free() it. And TIdStack.AddLocalAddressesToList() is deprecated anyway, you should be using TIdStack.GetLocalAddressList() instead.
Try this:
procedure TForm2.CheckBox6Click(Sender: TObject);
var
ic: integer;
allIpList : TIdStackLocalAddressList;
begin
AbLED412.Checked := CheckBox6.Checked;
if CheckBox6.Checked then
begin
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55000;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55001;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55003;
end;
IdTCPServer1.Active := True;
allIpList := TIdStackLocalAddressList.Create;
try
GStack.GetLocalAddressesList( allIpList );
Memo14.Lines.Clear;
{
for ic := 0 to IdTCPServer1.Bindings.Count-1 do
begin
Memo14.Lines.Add('Create tcp connection on ip : ' + IdTCPServer1.Bindings[ic].IP + ' and port : ' + IntToStr(IdTCPServer1.Bindings[ic].Port));
end;
}
for ic := 0 to allIpList.Count-1 do
begin
if allIpList[ic].IPVersion = ID_DEFAULT_IP_VERSION then
begin
Memo14.Lines.Add('Create tcp connection on ip : ' + allIpList[ic].IPAddress + ' and port : 55000');
Memo14.Lines.Add('Create tcp connection on ip : ' + allIpList[ic].IPAddress + ' and port : 55001');
Memo14.Lines.Add('Create tcp connection on ip : ' + allIpList[ic].IPAddress + ' and port : 55003');
end;
end;
finally
allIpList.Free;
end;
end
else
begin
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
Memo14.Lines.Clear;
end;
end;

Related

Delphi service app crashes at a random time

I have a Delphi Service app. Indy TCP server and many clients (up to 50), ADO connection to Firebird and simply network exchange. App randomly crashes (may be workin 7 days, may be 1 hour) with next event (for example):
Имя сбойного приложения: rollcontrol.exe, версия: 1.1.20.2, метка времени: 0x60acd5f2
Имя сбойного модуля: ntdll.dll, версия: 6.3.9600.19678, метка времени: 0x5e82c0f7
Код исключения: 0xc0000005
Смещение ошибки: 0x00058def
Идентификатор сбойного процесса: 0x4178
or:
Имя сбойного приложения: rollcontrol.exe, версия: 1.1.1.9, метка времени: 0x607b239c
Имя сбойного модуля: msvcrt.dll, версия: 7.0.9600.16384, метка времени: 0x52158ff5
Код исключения: 0xc0000005
Смещение ошибки: 0x00009e80
All jobs in app makes in anonimius threads or in tcp/ip connections threads. All code in each thread executed in try except statments. There no memory leaks or growing threads count. The main code of service thread very simple:
procedure TRollControl_Svc.ServiceExecute(Sender: TService);
begin
while not Terminated do
try
ServiceThread.ProcessRequests(False);
ServiceThread.Sleep(100);
except
on e : exception do LogException('ServiceExecute', E);
end;
end;
How I can handled this exception and prevent app crash? How it possible to crash service thread with two simple lines of code?
Thanks
UPDATE: Example of connections to DB:
function TRollControl_Svc.GetNodeIdByIP(ip: string): integer;
Var
SQLConnection : TADOConnection;
SQLQuery : TADOQuery;
Thread : TThread;
fResult : integer;
begin
fResult := 0;
try
Thread := nil;
Thread := TThread.CreateAnonymousThread(
procedure
begin
try
SQLConnection := nil;
SQLQuery := nil;
CoInitialize(nil);
SQLConnection := TADOConnection.Create(nil);
SQLConnection.ConnectionString := 'Provider=MSDASQL.1;Password=' + Psw + ';Persist Security Info=True;User ID=' + Usr + ';Data Source=' + Srv ;
SQLConnection.LoginPrompt := false;
SQLQuery := TADOQuery.Create(nil);
SQLQuery.Connection := SQLConnection;
SQLQuery.LockType := ltReadOnly;
try SQLConnection.Open; except SQLConnection.Open; end;
SQLConnection.BeginTrans;
SQLQuery.Close;
SQLQuery.SQL.Text := 'select nodes.* from nodes where nodes.ip = :ip';
SQLQuery.Parameters.ParamByName('ip').Value := ip;
try SQLQuery.Open; except SQLQuery.Open; end;
if SQLQuery.IsEmpty then exit;
fResult := SQLQuery.FieldByName('ID').AsInteger;
if SQLConnection.InTransaction then
SQLConnection.CommitTrans;
finally
TryFree(SQLQuery);
TryFree(SQLConnection);
CoUninitialize;
end;
end
);
Thread.FreeOnTerminate := false;
Thread.Start;
Thread.WaitFor;
finally
TryFree(Thread);
end;
result := fResult;
end;
Error Handling
This isn't an answer as to what is causing your problem, but I thought it probably wouldn't be clear in a comment.
In languages that support structured exception handling the language gives the programmer an opportunity to fail gracefully when things don't work. That's not how you are using it. From your example anonymous thread you have:
try SQLConnection.Open; except SQLConnection.Open; end;
So you are told that the connection can't be made and instead of responding to that situation you go ahead and attempt to connect again. There are lots of reasons why a connection may not work, some of those are transient so the attempt may work a little later but if you simply try doing it again without any pause it seems reasonable to expect it to fail again.
It's obviously important to catch errors, but you have to have appropriate failure paths.
I have no way of knowing if this is related to what's actually going wrong.
I found the reason. The problem was in the ADO source codes (Data.Win.ADODB.pas):
procedure RefreshFromOleDB;
var
I: Integer;
ParamCount: ULONG_PTR;
ParamInfo: PDBParamInfoArray;
NamesBuffer: POleStr;
Name: WideString;
Parameter: _Parameter;
Direction: ParameterDirectionEnum;
OLEDBCommand: ICommand;
OLEDBParameters: ICommandWithParameters;
CommandPrepare: ICommandPrepare;
begin
OLEDBCommand := (Command.CommandObject as ADOCommandConstruction).OLEDBCommand as ICommand;
OLEDBCommand.QueryInterface(ICommandWithParameters, OLEDBParameters);
OLEDBParameters.SetParameterInfo(0, nil, nil); // ----- Error here
if Assigned(OLEDBParameters) then
begin
ParamInfo := nil;
NamesBuffer := nil;
try
OLEDBCommand.QueryInterface(ICommandPrepare, CommandPrepare);
if Assigned(CommandPrepare) then CommandPrepare.Prepare(0);
if OLEDBParameters.GetParameterInfo(ParamCount, PDBPARAMINFO(ParamInfo), #NamesBuffer) = S_OK then
for I := 0 to ParamCount - 1 do//
begin
{ When no default name, fabricate one like ADO does }
if ParamInfo[I].pwszName = nil then
Name := 'Param' + IntToStr(I+1) else { Do not localize }
Name := ParamInfo[I].pwszName;
{ ADO maps DBTYPE_BYTES to adVarBinary }
if ParamInfo[I].wType = DBTYPE_BYTES then ParamInfo[I].wType := adVarBinary;
{ ADO maps DBTYPE_STR to adVarChar }
if ParamInfo[I].wType = DBTYPE_STR then ParamInfo[I].wType := adVarChar;
{ ADO maps DBTYPE_WSTR to adVarWChar }
if ParamInfo[I].wType = DBTYPE_WSTR then ParamInfo[I].wType := adVarWChar;
Direction := ParamInfo[I].dwFlags and $F;
{ Verify that the Direction is initialized }
if Direction = adParamUnknown then Direction := adParamInput;
Parameter := Command.CommandObject.CreateParameter(Name, ParamInfo[I].wType, Direction, ParamInfo[I].ulParamSize, EmptyParam);
Parameter.Precision := ParamInfo[I].bPrecision;
Parameter.NumericScale := ParamInfo[I].bScale;
//if ParamInfo[I].dwFlags and $FFFFFFF0 <= adParamSigned + adParamNullable + adParamLong then
Parameter.Attributes := ParamInfo[I].dwFlags and $FFFFFFF0; { Mask out Input/Output flags }
AddParameter.FParameter := Parameter;
end;
finally
if Assigned(CommandPrepare) then CommandPrepare.Unprepare;
if (ParamInfo <> nil) then GlobalMalloc.Free(ParamInfo);
if (NamesBuffer <> nil) then GlobalMalloc.Free(NamesBuffer);
end;
end;
end;
Line
OLEDBParameters.SetParameterInfo(0, nil, nil)
executed before
if Assigned(OLEDBParameters)
I moved this line after checking on nil and all working fine
I managed to isolate the problem. Errors occur periodically when working with ADO. If I try to use TADOQuery objects again, the application more susceptible to crashes. What I've done:
System.NeverSleepOnMMThreadContention: = false;
Significantly reduces errors when working with ADO
All uses of TADOQuery are single use.
For example it was:
for ii := 0 to SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'].Count - 1 do
begin
try
SQLQuery.Close;
SQLQuery.SQL.Text := SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'][ii].AsString;
SQLQuery.ExecSQL;
except
on e : exception do LogException('ClearBase', '', E);
end;
end;
Became:
for ii := 0 to SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'].Count - 1 do
begin
SQLQuery := nil;
try
SQLQuery := TADOQuery.Create(nil);
SQLQuery.Connection := SQLConnection;
try
SQLQuery.Close;
SQLQuery.SQL.Text := SettingsXML.Root.NamedItem['sql_clear_base'].NamedItem['XML'][ii].AsString;
SQLQuery.ExecSQL;
except
on e : exception do LogException('ClearBase', '', E);
end;
finally
TryFree(SQLQuery);
end;
end;
I make self-control:
main procces started as windows service (process A)
process A starts a copy of itself as B
one per minutes A check if B alive and restart if not
one per minutes B check if A alive and restart if not
check - simple TCP packet and answer
For example:
TThread.CreateAnonymousThread(
procedure
var tcpClient : TidTCPClient;
begin
tcpClient := nil;
LastKeepAlive := Date + Time;
while ServerMode do
begin
try
if not Assigned(tcpClient) then
begin
tcpClient := TIdTCPClient.Create(nil);
tcpClient.Host := '127.0.0.1';
tcpClient.Port := RollControl_Svc.TCPServer.Bindings[0].Port;
tcpClient.Connect;
tcpClient.IOHandler.ReadTimeout := 1000;
end;
tcpClient.IOHandler.Write(START_PACKET + #0 + END_PACKET);
tcpClient.IOHandler.ReadString(3);
LastKeepAlive := Date + Time;
except
TryFree(tcpClient);
end;
sleep(15 * 1000);
end;
end).Start;
TThread.CreateAnonymousThread(
procedure
Var Res: TRequestResult;
begin
while ServerMode do
begin
if Date + Time - LastKeepAlive > OneMinute then
begin
Res.Clear('', '');
Res.Nodes_ID := -1;
Res.Data_In := 'KeepAlive';
Res.Data_Out := 'Exception: ExitProcess(1)';
try
Log(Res, true);
finally
ExitProcess(1);
end;
end;
sleep(1000);
end;
end).Start;
P.S. Local tests never crashed applications. The program simply proceed a million requests (connect, request, disconnect), there are no memory leaks or failures. On several clients servers are crashed. In the future I want to port to Lazarus to use ODBC directly insteed ADO

TIdTCPServer not able to send data after re-connection of client

I am using TIdTCPServer in my application. Here hardware acting as tcp client. Client establishes the connection with SYN command (observed in wire shark which is a tool). My application has multiple clients so every client connects to my server. For the first time connection, data sending & receiving is fine. But when hardware power off & on happens, my server not able to send data, to hardware, until application restart. Following are the observations regarding this:
1.When first time client connects SYN with Seq No = 0 received, SYN ACK with Seq No = 1 send to the client from server
2.Data sending & receiving are working fine
3.Hardware power off happened
4.In command prompt by using “netstat” i observed there is connection established for the disconnected IP & port number.
5.I send some data (in wire shark it displayed 6 times retransmission)
6.After this in “command prompt” corresponded connection established data not appeared
7.I send data to client now "Connection closed" exception raised by the IdTCPServer (after this exception, in on except, i closed the connection by using connection.disconnect in code & deleted that particular client from Locklist of IdTCPServer.)
8.Hardware powered on & send SYN with Seq No = 0
9.In wire shark SYN ACK with Seq No like 45678452 sent to hardware
10.After that in command prompt connection establishment was observed
11.I tried to send data to client, but “Locklist” not updated with the client IP& port again so data not sent the client (my code is like if IP not present in “Locklist” then not sending data).
Is there any solutions?
Following is my code:
try
for Count := 0 to frmtcpserver.IdTCPServer1.Contexts.LockList.Count - 1
do
begin
if TIdContext(frmtcpserver.IdTCPServer1.Contexts.LockList.Items[Count]).Binding.PeerIP = Destination_IP then
begin
DestinationIPIdx := Count;
end;
end;
frmtcpserver.IdTCPServer1.Contexts.UnlockList;
if DestinationIPIdx > -1 then
begin
// sending data here
TIdContext(frmtcpserver.IdTCPServer1.Contexts.LockList.Items[DestinationIPIdx])
.Connection.IOHandler.Write(TempBuf, NoofBytesToSend,0);
end;
end;
on E: EidException do
begin
TIdContext(frmtcpserver.IdTCPServer1.Contexts.LockList.Items[DestinationIPIdx]).Connection.Disconnect;
frmtcpserver.IdTCPServer1.Contexts.LockList.Delete(DestinationIPIdx);
end;
You are calling Contexts.LockList() WAY too many times. The contexts list is protected by a critical section. The calls to LockList() and UnlockList() MUST be balanced or you will deadlock the server, preventing clients from connecting and disconnecting.
LockList() returns the actual list. So, you should lock it once, access its items as needed, and then unlock it once.
Try something more like this instead:
list := frmtcpserver.IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count - 1 do
begin
ctx := TIdContext(list[i]);
if ctx.Binding.PeerIP = Destination_IP then
begin
// sending data here
try
ctx.Connection.IOHandler.Write(TempBuf, NoofBytesToSend, 0);
except
on E: EIdException do
begin
ctx.Connection.Disconnect;
end;
end;
break;
end;
end;
finally
frmtcpserver.IdTCPServer1.Contexts.UnlockList;
end;
That being said, if the server's OnExecute event is communicating back and forth with the client then it is generally not safe to directly send data to a client from outside of the client's OnExecute event, like you are doing. You risk corrupting the communications. It is safer to give each client context its own thread-safe queue of outgoing data, and then use the OnExecute event to send that data when it is safe to do so. For example:
type
TMyContext = class(TIdServerContext)
public
Queue: TThreadList;
...
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil); override;
destructor Destroy; override;
end;
PIdBytes := ^TIdBytes;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TThreadList = nil);
begin
inherited;
Queue := TThreadList.Create;
end;
destructor TMyContext.Destroy;
var
list: TList;
I: integer;
begin
list := Queue.LockList;
try
for i := 0 to list.Count-1 do
begin
PIdBytes(list[i])^ := nil;
Dispose(list[i]);
end;
finally
Queue.UnlockList;
end;
Queue.Free;
inherited;
end;
procedure TFrmTcpServer.FormCreate(Sender: TObject);
begin
IdTCPServer1.ContextClass := TMyContext;
end;
procedure TFrmTcpServer.IdTCPServer1Execute(AContext: TIdContext);
var
Queue: TList;
tmpList: TList;
i: integer;
begin
...
tmpList := nil;
try
Queue := TMyContext(AContext).Queue.LockList;
try
if Queue.Count > 0 then
begin
tmpList := TList.Create;
tmpList.Assign(Queue);
Queue.Clear;
end;
finally
TMyContext(AContext).Queue.UnlockList;
end;
if tmpList <> nil then
begin
for i := 0 to tmpList.Count-1 do
begin
AContext.Connection.IOHandler.Write(PIdBytes(tmpList[i])^);
end;
end;
finally
if tmpList <> nil then
begin
for i := 0 to tmpList.Count-1 do
begin
PIdBytes(tmpList[i])^ := nil;
Dispose(tmpList[i]);
end;
end;
tmpList.Free;
end;
...
end;
var
list: TList;
ctx: TIdContext;
I: integer;
data: PIdBytes;
begin
list := IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count - 1 do
begin
ctx := TIdContext(list[i]);
if ctx.Binding.PeerIP = Destination_IP then
begin
New(data);
try
data^ := Copy(TempBuf, 0, NoofBytesToSend);
TMyContext(ctx).Queue.Add(data);
except
data^ := nil;
Dispose(data);
end;
break;
end;
end;
end;
finally
IdTCPServer1.Contexts.UnlockList;
end;

Indy : Object[i].delete method can't free memory?

This is my simple code for queue[i] freeing memory ...
Is it correct?
The monitor is a customized TIdContext object.
...
var queue : TList;
...
queue := monitor.Screenshots.LockList;
if queue.Count > 0 then
begin
for i := 0 to queue.Count - 1 do
begin
if TScreenshotInfo(queue[i]).ClientIP = request_AgentIP then
begin
screenshot := TScreenshotInfo(queue[i]);
end;
queue.Delete(i);//Can't free queue[i] from memory?
end;
end;
...
queue := monitor.Screenshots.LockList;
try
for queue.Count-1 downto 0 do begin
if TScreenshotInfo(queue[i]).ClientIP = request_AgentIP then
TScreenshotInfo(queue[i]).Free;//queue[i] freed
queue.Delete(i);
end;
finally
monitor.Screenshots.UnlockList;
end;
I assume there's some reason why an item is deleted and not freed if it doesn't match the condition.
As I already explained in comments to your other question on this same issue:
You have memory leaks in IdTCPServer_SendExecute(). IdTCPServer_RecvExecute() queues a screenshot to all connected monitors, but IdTCPServer_SendExecute() only processes screenshots from a specific client, discarding all other client screenshots from the queue without freeing them from memory. Also, if multiple screenshots from the desired client are in the queue, you only process the last screenshot, discarding the earlier screenshots without freeing them. In short, your loop processing in IdTCPServer_SendExecute() has logic holes in it.
The code needs to look more like this:
destructor TMonitorContext.Destroy;
var
queue: TList;
i: Integer;
begin
queue := Screenshots.LockList;
try
for i := 0 to queue.Count - 1 do begin
TScreenshotInfo(queue[i]).Free;
end;
finally
Screenshots.UnlockList;
end;
Screenshots.Free;
CloseHandle(ScreenshotEvent);
inherited;
end;
procedure TIndyServerForm.IdTCPServer_SendExecute(AContext: TIdContext);
var
monitor: TMonitorContext;
queue: TList;
screenshot: TScreenshotInfo;
request_AgentIP: string;
begin
monitor := TMonitorContext(AContext);
if WaitForSingleObject(monitor.ScreenshotEvent, 1000) <> WAIT_OBJECT_0 then begin
Exit;
end;
// you really should not be requesting an IP on every screenshot sent.
// request an IP once at connection, and don't request a new IP unless
// you want to monitor a different client. This is especially useful
// for allowing IdTCPServer_Recv to not queue screenshots this monitor
// is not interested in receiving...
request_AgentIP := AContext.Connection.IOHandler.ReadLn;
screenshot := nil;
try
queue := monitor.Screenshots.LockList;
try
while queue.Count > 0 do
begin
screenshot := TScreenshotInfo(queue[0]);
queue.Delete(0);
if screenshot.ClientIP = request_AgentIP then
Break;
end;
FreeAndNil(screenshot);
end;
if queue.Count = 0 then
ResetEvent(monitor.ScreenshotEvent);
finally
monitor.Screenshots.UnlockList;
end;
if screenshot = nil then begin
Exit;
end;
// you should send screenshot.ClientIP and screenshot.ClientPort to
// this monitor so it knows which client the screenshot came from...
if not SendStream(AContext, screenshot.Data) then
begin
SOutMsg :='viewer : ' + AContext.Binding.PeerIP + ': reqIP(' + request_AgentIP + ')-> image send failed : ' + KBStr(screenshot.Data.Size) +' #'+TimeToStr(Now);
AContext.Connection.Disconnect;
end
else
begin
SOutMsg :='viewer : ' + AContext.Binding.PeerIP + ': reqIP(' + request_AgentIP + ')-> image send success : ' + KBStr(screenshot.Data.Size)+' #'+TimeToStr(Now);
end;
finally
screenshot.Free;
end;
end;

TIdHttp freezes when the internet gets slower

How to avoid freezing the idHTTP when the internet become slower or no connectivity. My application get freeze and I could not even close the form.
This is how I setup my code
procedure TDownloader.IdHTTPWork(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
var
lwElapsedMS: LongWord;
iBytesTransferred: Int64;
iBytesPerSec: Int64;
iRemaining: Integer;
begin
if AWorkMode <> wmRead then Exit;
lwElapsedMS := GetTickDiff(FLastTicks, Ticks);
if lwElapsedMS = 0 then lwElapsedMS := 1; // avoid EDivByZero error
if FTotalBytes > 0 then
FPercentDone := Round(AWorkCount / FTotalBytes * 100.0)
else
FPercentDone := 0;
iBytesTransferred := AWorkCount - FLastWorkCount;
iBytesPerSec := Round(iBytesTransferred * 1000 / lwElapsedMS);
if Assigned(OnDownloadProgress) then
begin
if FContinueDownload <> 0 then //previous file downloaded
begin
iRemaining := 100 - FContinueDownload;
iRemaining := Round(FPercentDone * iRemaining / 100);
OnDownloadProgress(Self, FContinueDownload + iRemaining, AWorkCount, FTotalBytes, iBytesPerSec);
end else
OnDownloadProgress(Self, FPercentDone, AWorkCount, FTotalBytes, iBytesPerSec);
end;
FLastWorkCount := AWorkCount;
FLastTicks := Ticks;
if FCancel then
begin
Abort;
TidHttp(ASender).Disconnect;
end;
end;
procedure TDownloader.IdHTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Int64);
begin
if AWorkMode <> wmRead then Exit;
FPercentDone := 0;
FTotalBytes := AWorkCountMax;
FLastWorkCount := 0;
FLastTicks := Ticks;
end;
procedure TDownloader.IdHTTPWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
if AWorkMode <> wmRead then Exit;
if Assigned(OnDownloadComplete) and (FPercentDone >= 100) then
OnDownloadComplete(Self)
else if Assigned(OnDownloadCancel) then
OnDownloadCancel(Self);
end;
function TDownloader.EXDownload(AURL, ADestFile: String;
AAutoDisconnect: Boolean): Boolean;
var
fsBuffer: TFileStream;
idHttp: TIdHttp;
begin
if FileExists(ADestFile) then
fsBuffer := TFileStream.Create(ADestFile, fmOpenReadWrite)
else
fsBuffer := TFileStream.Create(ADestFile, fmCreate);
fsBuffer.Seek(0, soFromEnd);
try
idHttp := TIdHttp.Create(nil);
idHttp.OnWorkBegin := idHttpWorkBegin;
idHttp.OnWork := idHttpWork;
idHttp.OnWorkEnd := idHttpWorkEnd;
idHttp.Request.CacheControl := 'no-store';
try
...
idHttp.Get(AURL, fsBuffer);
...
finally
idHttp.Free;
end;
finally
fsBuffer.Free;
end;
end;
......
procedure TDownloader.Execute;
begin
Inherited;
while not Terminated do
begin
if FUrl <> '' then
begin
EXDownload(FUrl, FFilename, True);
end;
end;
end;
...
on the main form progress
procedure TfrmDownloadList.DownloadProgress(Sender: TObject; aPercent:Integer;
aProgress, aProgressMax, aBytesPerSec: Int64);
var
yts: PYoutubeSearchInfo;
begin
if Assigned(FCurrentDownload) then
begin
yts := vstList.GetNodeData(FCurrentDownload);
yts.Tag := aPercent;
ProgressBar.Position := aPercent;
vstList.InvalidateNode(FCurrentDownload);
StatusBar.Panels.Items[1].Text := 'Download: ' + FormatByteSize(aProgress) + '/' +
FormatByteSize(aProgressMax);
StatusBar.Panels.Items[2].Text := 'Speed: ' + FormatByteSize(aBytesPerSec) + 'ps';
Application.ProcessMessages;
end;
end;
I don't have problem when the internet is good only when it drops due to poor signal.
this is my app lookslike
If we assume that TDownloader.OnDownloadProgress is assigned to the TfrmDownloadList.DownloadProgress method, then your problem is that you are calling VCL code (your update of the progress bar) from a secondary thread (ie. not from the Main thread). This is not supported.
You'll need to wrap the call with a Synchronize statement from within your thread. Synchronize calls a parameterless method on the main thread. So you need to store the variables that are needed and then call Synchronize on a method in your TDownloader class that then calls on to TfrmDownloadList.DownloadProgress
You cannot call TfrmDownloadList.DownloadProgress directly or indirectly from within code that runs on another thread than the main thread, as it updates VCL objects, and the VCL is not thread-safe.
The same goes for your DownloadComplete event, if it updates any VCL objects...
How about you using TIdAntiFreeze ?
TIdAntiFreeze implements a GUI-integration class that ensures
processor time is allocated for the Application main thread.
Indy works on the blocking sockets model. Calls made to methods in the
Indy components do not return until they are complete. If calls are
made in the main thread, this will cause the Application User
Interface to "freeze" during Indy calls. TIdAntiFreeze counteracts
this effect.
TIdAntiFreeze allows Indy to process Application messages so that
Windows messages continue to be executed while Indy blocking socket
calls are in effect.
Only one TIdAntiFreeze can be active in an application.

how to block unknown clients in indy (Delphi)

I have a public server(configured with indy 10) . some unknown clients are sending thousands of no content messages that it change the server's cpu usage to 50% . i have no firewall on my server , so i tried to block the unknown clients with this codes :
This is a function that works with a Timer :
var
i, j: integer;
begin
IX2 := IX2 + 1;
SetLength(ClientIPs, IX2);
ClientIPs[IX2 - 1] := StrIP;
j := 0;
for i := low(ClientIPs) to high(ClientIPs) do
begin
Application.ProcessMessages;
if ClientIPs[i] = StrIP then
j := j + 1;
end;
if j > 10 then
begin
Result := false;
exit;
end;
Result := true;
And it's my Timer code :
//Reset filtering measures
IX2 := 0;
SetLength(ClientIPs, 0);
So i use it in OnExecute event :
LogIP := AContext.Connection.Socket.Binding.PeerIP;
if IPFilter(LogIP) <> true then
begin
AContext.Connection.disconnect;
exit;
end;
//Get Data *********
Data := AContext.Connection.IOHandler.ReadLn();
finally , if a client sends many message in a short time , it will be disconnect . but there is a problem . in fact , after client disconnection , the Onexecute event is still working and i can not stop the operation Fully .anyway i need to block some IPs completely .
Thank you
The OnConnect event would be a better place to disconnect blacklisted IPs. The only reason to do the check in the OnExecute event is if the IP is not being blacklisted until after OnConnect has already been fired.
As for why OnExecute keeps running after you disconnect - the only way that can happen is if your OnExecute handler has a try..except block that is catching and discarding Indy's internal notifications. Any exception handling you do needs to re-raise EIdException-derived exceptions so the server can process them.
Followup to my earlier comment:
function TForm1.IPFilter(const StrIP: string): Boolean;
var
i, j: integer;
list: TList;
begin
j := 0;
list := IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count-1 do
begin
if TIdContext(list[i]).Binding.PeerIP = StrIP then
Inc(j);
end;
Result := j <= 10;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
begin
// the simpliest way to force a disconnect and stop
// the calling thread is to raise an exception...
if not IPFilter(AContext.Binding.PeerIP) then
Abort();
// alternatively, if you call Disconnect(), make sure
// the IOHandler's InputBuffer is empty, or else
// AContext.Connection.Connected() will continue
// returning True!...
{if not IPFilter(AContext.Binding.PeerIP) then
begin
AContext.Connection.Disconnect;
AContext.Connection.IOHandler.InputBuffer.Clear;
Exit;
end;}
//Get Data *********
Data := AContext.Connection.IOHandler.ReadLn();
end;

Resources