Delphi service app crashes at a random time - delphi

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

Related

delphi tcp server on multi port hanged on close

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;

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;

What is real web-url for mORMot web-service?

Please help to understand about routing and web-url of web-service below.
type
TAirportService = class(TInterfacedObject, IAirportService)
public
procedure GetAirportDefinition(const AirPortID: integer; out Definition: TDTOAirportDefinition);
end;
procedure TAirportService.GetAirportDefinition(const AirPortID: integer;
out Definition: TDTOAirportDefinition);
begin
// create an object from static data
// (real application may use database and complex code to retrieve the values)
with Definition.Airport.Add do begin
Location := 'LAX';
Terminal := TRawUTF8DynArrayFrom(['terminalA', 'terminalB', 'terminalC']);
Gate := TRawUTF8DynArrayFrom(['gate1', 'gate2', 'gate3', 'gate4', 'gate5']);
BHS := 'Siemens';
DCS := 'Altiea';
end;
with Definition.Airline.Add do begin
CX := TRawUTF8DynArrayFrom(['B777', 'B737', 'A380', 'A320']);
QR := TRawUTF8DynArrayFrom(['A319', 'A380', 'B787']);
ET := '380';
SQ := 'A320';
end;
Definition.GroundHandler := TRawUTF8DynArrayFrom(['Swissport','SATS','Wings','TollData']);
end;
procedure StartWebService();
var
aModel: TSQLModel;
aDB: TSQLRestServer;
aServer: TSQLHttpServer;
begin
// set the logs level to only important events (reduce .log size)
TSQLLog.Family.Level := LOG_STACKTRACE+[sllInfo,sllServer];
// initialize the ORM data model
aModel := TSQLModel.Create([]);
try
// create a fast in-memory ORM server
aDB := TSQLRestServerFullMemory.Create(aModel,'test.json',false,false);
try
// register our TAirportServer implementation
// aDB.ServiceRegister(TServiceCalculator,[TypeInfo(ICalculatorXML)],sicShared);
aDB.ServiceRegister(TAirportService,[TypeInfo(IAirportService)],sicShared);
// launch the HTTP server
aServer := TSQLHttpServer.Create('8092', [aDB], '+', useHttpApiRegisteringURI);
try
aServer.AccessControlAllowOrigin := '*'; // allow cross-site AJAX queries
writeln('Background server is running'#10);
write('Press [Enter] to close the server.');
ConsoleWaitForEnterKey;
finally
aServer.Free;
end;
finally
aDB.Free;
end;
finally
aModel.Free;
end;
end;
I try to call follow web-urls:
http://localhost:8092/root/AirportService/GetAirportDefinition?AirPortID=1
http://localhost:8092/root/AirportService.GetAirportDefinition?AirPortID=1
http://localhost:8092/root/AirportService/GetAirportDefinition
http://localhost:8092/AirportService/GetAirportDefinition?AirPortID=1
http://localhost:8092/AirportService.GetAirportDefinition?AirPortID=1
http://localhost:8092/AirportService/GetAirportDefinition
but every time I get:
{
"errorCode":400,
"errorText":"Bad Request"
}
or Bad request
Where am I wrong?
A was wrong, really urls below works as needed:
http://localhost:8092/root/AirportService/GetAirportDefinition?AirPortID=1
http://localhost:8092/root/AirportService.GetAirportDefinition?AirPortID=1

What does "Invalid address specified to RtlFreeHeap( 06450000, 08387460 )" mean?

Sometimes I experience random crashes in my Delphi program. My program halts, and the Debugger outputs:
Invalid address specified to RtlFreeHeap( 06450000, 08387460 )
What does that mean? And what can possibly cause it?
This is where the CPU Inspector stopped:
77BA0845 C6052582BD7700 mov byte ptr [$77bd8225],$00
Please note that they are very random (for me). Sometimes they don't appear at all.
I am using the Skype4COM.dll from Skype - there's no source though.
In case you need it, here is the code. I have commented most of the calls to Synchronize, so you know what they do.
////////////////////////////////////////////////////////////////////////////////
/// Execute
////////////////////////////////////////////////////////////////////////////////
procedure TContactDeletor.Execute;
Var
I : Integer;
UserObj : PUser;
User : IUser;
PauseEvent : TEvent;
begin
inherited;
FreeOnTerminate := True;
if Terminated then
Exit;
CoInitialize(Nil);
// The F-Flags are to make sure TSkype events do not fire (from my Main Thread)
FAllowUI := False;
FUserIsBeingDeleted := False;
FUseGroupUsersEvent := False;
FUseRenameEvent := False;
SkypeThr := TSkype.Create(Nil);
SkypeThr.Attach(10,False);
SkypeThr.Cache := False;
MyList := TStringList.Create;
PauseEvent := TEvent.Create(True);
try
// This fills my Stringlist
Synchronize(GrabList);
if Terminated then Exit;
iMax := MyList.Count;
// This sets the Max of my Progressbar
Synchronize(SetMax);
Try
for I := 0 to MyList.Count - 1 do
begin
{while SkypeThr.AttachmentStatus <> apiAttachSuccess do
begin
SkypeThr.Attach(10,False);
Synchronize(Procedure Begin Log('Skype Unavailable - Trying to reconnect ...'); End);
PauseEvent.WaitFor(5000);
end; }
CurUser := '';
User := SkypeThr.User[MyList[I]];
CurUser := MyList[I];
Try
User.IsAuthorized := False;
User.BuddyStatus := budDeletedFriend;
Except on E:Exception do
begin
ExErr := E.Message;
ExLog := 'Error while deleting contacts: ';
ExMsg := 'An Error has occured while deleting contacts: ';
Synchronize(
Procedure
Begin
Log(ExLog+ExErr+sLineBreak+' - Last logged Handle: '+CurUser);
End
);
end;
end;
iProgress := I+1;
// This updates my log and my progressbar.
Synchronize(UpdatePG);
PauseEvent.WaitFor(100);
if (I mod 200 = 0) and (I > 0) then
begin
// Calls to Synchronize updates my log
Synchronize(SyncPauseBegin);
PauseEvent.WaitFor(3000);
Synchronize(SyncPauseEnd);
end;
end;
// Except
Except on E:Exception do
begin
ExErr := E.Message;
ExLog := 'Error while deleting contacts: ';
ExMsg := 'An Error has occured while deleting contacts: ';
Synchronize(
Procedure
Begin
Log(ExMsg+ExErr+sLineBreak+' - Last logged Handle: '+CurUser);
ErrMsg(ExMsg+ExErr+sLineBreak+sLineBreak+' - Last logged Handle: '+CurUser);
End
);
Exit;
end;
end;
// This synchronizes my visual list.
Synchronize(SyncList);
finally
FUserIsBeingDeleted := False;
FUseGroupUsersEvent := True;
FUseRenameEvent := True;
FAllowUI := True;
Synchronize(
Procedure
Begin
frmMain.UpdateStatusBar;
PleaseWait(False);
ToggleUI(True);
end);
PauseEvent.Free;
SkypeThr.Free;
MyList.Free;
CoUninitialize;
end;
end;
Najem was correct, it is because your heap is corrupted. To debug it easier, you should enable PageHeap, also, use the debug CRT (or debug delphi runtime) as much as possiable until you find out what's corrupting your memory.
A lot of the time, the corruption may only spill over a few bytes. Then your application can run fine for a very long time, so you will not notice anything wrong until much later, if at all.
Try to exit your application cleanly when your looking for memory corruption bugs, dont just stop the debugger, when your process is exiting, it should "touch" most of the memory it allocated earlier and it will give you a chance to detect the failure.

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