how to block unknown clients in indy (Delphi) - 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;

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

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;

How to start a windows service in Delphi for Windows 8

I need to Start a service using Delphi Windows application.It is working fine in Windows 7 but not working in Windows 8.1 .I have used the following code
function ServiceStart(sMachine,sService : string ) : boolean;
var
schm,schs : SC_Handle;
ss : TServiceStatus;
psTemp : PChar;
dwChkP : DWord;
begin
ss.dwCurrentState := 0;
schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);
if(schm > 0)then
begin
schs := OpenService(schm,PChar(sService),SERVICE_START or SERVICE_QUERY_STATUS);
if(schs > 0)then
begin
psTemp := Nil;
if(StartService(schs,0,psTemp))then
begin
if(QueryServiceStatus(schs,ss))then
begin
while(SERVICE_RUNNING <> ss.dwCurrentState)do
begin
dwChkP := ss.dwCheckPoint;
Sleep(ss.dwWaitHint);
if(not QueryServiceStatus(schs,ss))then
begin
break;
end;
if(ss.dwCheckPoint < dwChkP)then
begin
break;
end;
end;
end;
end;
CloseServiceHandle(schs);
end;
CloseServiceHandle(schm);
end;
Result := SERVICE_RUNNING = ss.dwCurrentState;
end;
procedure TForm1.BBSerStatusClick(Sender: TObject);
begin
ServiceStart('','SERVTEST');
end;
Note: SERVTEST it is service application.
Can anyone help me?
I see that you are using code copied from here.
if(schm > 0)then and if(schs > 0)then should be changed to if(schm <> 0)then and if(schs <> 0) then instead. The only failure value in this situation is 0 (some APIs use INVALID_HANDLE_VALUE instead, but the SCM API does not). Any other value is a valid handle. Handles are not really integers (although Delphi declares them as such), so you should not treat them as integers. They are arbitrary values that are not meant to be interpreted, they are meant to be used as-is. If you do not get back an actual failure value (in this case, 0), then the call was successful regardless of the value actully returned.
The handling of ss.dwCurrentState is a little off, too. Instead of looping while ss.dwCurrentState is not SERVICE_RUNNING, loop while ss.dwCurrentState is SERVICE_START_PENDING instead. If something goes wrong and the service never enters the SERVICE_RUNNING state, the loop will run forever, unless QueryServiceStatus() itself fails. And I would not suggest relying on ss.dwCheckPoint because not all services implement it correctly (in fact, Delphi's own TService does not - see QC #1006 TService.ReportStatus reports incorrect CheckPoint).
Try something more like the following. It differentiates between SCM API failures and Service start failures, but also does extra error checking to handle certain errors that are not actually fatal errors:
function ServiceStart(sMachine, sService : string) : Boolean;
var
schm, schs : SC_HANDLE;
ss : TServiceStatus;
begin
schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
if (schm = 0) then RaiseLastOSError;
try
schs := OpenService(schm, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
if (schs = 0) then RaiseLastOSError;
try
// NOTE: if you use a version of Delphi that incorrectly declares
// StartService() with a 'var' lpServiceArgVectors parameter, you
// can't pass a nil value directly in the 3rd parameter, you would
// have to pass it indirectly as either PPChar(nil)^ or PChar(nil^)
if not StartService(schs, 0, nil) then
begin
Result := ERROR_SERVICE_ALREADY_RUNNING = GetLastError();
if not Result then RaiseLastOSError;
Exit;
end;
repeat
if not QueryServiceStatus(schs, ss) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
Result := False;
Exit;
end;
if (SERVICE_START_PENDING <> ss.dwCurrentState) then Break;
Sleep(ss.dwWaitHint);
until False;
Result := SERVICE_RUNNING = ss.dwCurrentState;
finally
CloseServiceHandle(schs);
end;
finally
CloseServiceHandle(schm);
end;
end;
Or, here is a (modified) version of Microsoft's example, which also includes handling if the service is in SERVICE_STOP_PENDING state before starting it (I removed timeout logic since it is based on dwCheckPoint handling):
Starting a Service:
function ServiceStart(sMachine, sService : string) : Boolean;
var
schSCManager,
schService : SC_HANDLE;
ssStatus : TServiceStatus;
begin
// Get a handle to the SCM database.
schSCManager := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
if (schSCManager = 0) then RaiseLastOSError;
try
// Get a handle to the service.
schService := OpenService(schSCManager, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
if (schService = 0) then RaiseLastOSError;
try
// Check the status in case the service is not stopped.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
end;
// Check if the service is already running
if (ssStatus.dwCurrentState <> SERVICE_STOPPED) and ssStatus.dwCurrentState <> SERVICE_STOP_PENDING) then
begin
Result := True;
Exit;
end;
// Wait for the service to stop before attempting to start it.
while (ssStatus.dwCurrentState = SERVICE_STOP_PENDING) do
begin
// Do not wait longer than the wait hint. A good interval is
// one-tenth of the wait hint but not less than 1 second
// and not more than 10 seconds.
dwWaitTime := ssStatus.dwWaitHint div 10;
if (dwWaitTime < 1000) then
dwWaitTime := 1000
else if (dwWaitTime > 10000) then
dwWaitTime := 10000;
Sleep(dwWaitTime);
// Check the status until the service is no longer stop pending.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
Break;
end;
end;
// Attempt to start the service.
// NOTE: if you use a version of Delphi that incorrectly declares
// StartService() with a 'var' lpServiceArgVectors parameter, you
// can't pass a nil value directly in the 3rd parameter, you would
// have to pass it indirectly as either PPChar(nil)^ or PChar(nil^)
if not StartService(schService, 0, nil) then RaiseLastOSError;
// Check the status until the service is no longer start pending.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
end;
while (ssStatus.dwCurrentState = SERVICE_START_PENDING) do
begin
// Do not wait longer than the wait hint. A good interval is
// one-tenth the wait hint, but no less than 1 second and no
// more than 10 seconds.
dwWaitTime := ssStatus.dwWaitHint div 10;
if (dwWaitTime < 1000) then
dwWaitTime := 1000
else if (dwWaitTime > 10000) then
dwWaitTime := 10000;
Sleep(dwWaitTime);
// Check the status again.
if not QueryServiceStatus(schService, ssStatus) then
begin
if (ERROR_SERVICE_NOT_ACTIVE <> GetLastError()) then RaiseLastOSError;
ssStatus.dwCurrentState := SERVICE_STOPPED;
Break;
end;
end;
// Determine whether the service is running.
Result := (ssStatus.dwCurrentState = SERVICE_RUNNING);
finally
CloseServiceHandle(schService);
end;
finally
CloseServiceHandle(schSCManager);
end;
end;

I keep receiving 0 byte from TClientSocket

Using DbgView, i saw that after i receive a Stream, the server then receives 0 bytes like more than 100 times, what is this ? this is new to me, i never saw this happening.
i personally have a feeling it is a client-side issue, could it ?
this is how i receive the stream server-side:
FMemStream := Socket.ReceiveStream(FMemStreamSize, cbUpdateStreamProgBar);
try
doClientReadStreamEnd;
finally
FMemStream.Free;
FInStreamMode := False; // we're not in stream mode anymore
end;
function TCustomWinSocketHelpher.ReceiveStream(StreamLen: Integer; Callback: TUpdateProgBarProc): TMemoryStream;
const
ChunkSize = 4096; // 4kb
var
PData: PByte;
ReadAmount: Integer;
begin
Result := TMemoryStream.Create;
GetMem(PData, StreamLen);
try
while StreamLen > 0 do
begin
ReadAmount := ReceiveBuf(PData^, ChunkSize);
if (ReadAmount > 0) then
begin
Result.Write(PData^, ReadAmount);
Callback(ReadAmount); // update gui
Inc(PData^, ReadAmount); // update PData current position
Dec(StreamLen, ReadAmount); // update loop condition
end;
end;
finally
FreeMem(PData);
end;
end;
on client-side, this is how i send stream:
FClientSocket.Socket.SendStreamEx(RemoteProcedureCalls.Stream);
procedure TCustomWinSocketHelpher.SendStreamEx(Stream: TStream);
begin
Stream.Seek(0, TSeekOrigin.soBeginning);
SendStream(Stream);
end;
Here's a photo of how it looks, it should not continue sending after line 5.
When ReceiveBuf() returns 0, it means the socket has been disconnected by the other party. You are not handling that condition, so you keep looping, getting back 0 again and again. Any value less than 1 is a failed read and needs to be treated as such. If ReceiveBuf() returns -1, an actual read error occurred, but that result can only be returned if the error was WSAEWOULDBLOCK, which is not fatal, or you have an OnError event handler assigned that is setting ErrorCode := 0. Otherwise, ReceiveBuf() would raise an ESocketError exception on a real socket error.
Try this:
function TCustomWinSocketHelpher.ReceiveStream(StreamLen: Integer; Callback: TUpdateProgBarProc): TMemoryStream;
const
ChunkSize = 4096; // 4kb
var
PData: PByte;
ReadAmount: Integer;
begin
Result := TMemoryStream.Create;
try
GetMem(PData, ChunkSize);
try
while StreamLen > 0 do
begin
ReadAmount := ReceiveBuf(PData^, Min(ChunkSize, StreamLen));
if ReadAmount < 0 then
begin
if WSAGetLastError() = WSAEWOULDBLOCK then
Continue;
// an OnError event handler must have disabled an exception being raised
Exit;
end;
if ReadAmount = 0 then
begin
// socket disconnected
raise Exception.Create(''); // or just Exit if you don't mind that the expected data is incomplete
end;
Result.WriteBuffer(PData^, ReadAmount);
Callback(ReadAmount); // update gui
Dec(StreamLen, ReadAmount); // update loop condition
end;
finally
FreeMem(PData);
end;
except
Result.Free;
raise;
end;
end;

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.

Resources