Delphi Indy TCP connection to RECON - delphi

I am trying to figure out how would be possible to get a connection and authentication stablished with the remote console.
This Wiki Wiki 1 and this one Wiki 2 tell me I need to build a packet and send it to the RECON, but I do not know how to do this..
I am a newbie with networking but since I was searching over there then I build this:
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPClient1.Host:= '127.0.0.1';
IdTCPClient1.Port:= 20001;
IdTCPClient1.Connect;
IdTcpClient1.IOHandler.Writeln('1234');
ShowMessage(IdTcpClient1.IOHandler.ReadLn);
end;
I am stucked there, where 1234 is the RECON password and the message that it return: Connection closed gracefully...
Finally, how can I log in successfully? And at least send a command "list" the next step would be receive the console log in realtime?
Thanks

Your code is not implementing the Source RECON protocol that the Minecraft commands run on top of. You can't just send arbitrary data to the server, it has to be framed properly.
Try something more like this instead:
const
SERVERDATA_AUTH = 3;
SERVERDATA_AUTH_RESPONSE = 2;
SERVERDATA_EXECCOMMAND = 2;
SERVERDATA_RESPONSE_VALUE = 0;
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPClient1.Host := '127.0.0.1';
IdTCPClient1.Port := 20001;
IdTCPClient1.Connect;
SendRECONLogin('1234');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
IdTCPClient1.Disconnect;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
SendRECONCommand('list');
end;
procedure TForm1.IdTCPClient1Connect(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure TForm1.IdTCPClient1Disconnect(Sender: TObject);
begin
Timer1.Enabled := False;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
RespID: Int32;
PktType: Int32;
Payload: string;
begin
try
if not IdTCPClient1.Connected then
Exit;
if IdTCPClient1.IOHandler.InputBufferIsEmpty then
begin
IdTCPClient1.IOHandler.CheckForDataOnSource(0);
IdTCPClient1.IOHandler.CheckForDisconnect(True, False);
if IdTCPClient1.IOHandler.InputBufferIsEmpty then Exit;
end;
RespID := ReadRECONPacket(PktType, Payload);
case PktType of
SERVERDATA_AUTH_RESPONSE: begin
if RespID = -1 then begin
// authentication failed...
IdTCPClient1.Disconnect;
end else begin
// authentication successful...
end;
end;
SERVERDATA_RESPONSE_VALUE: begin
// match RespID to previously sent ReqID
// and handle Payload as needed...
end;
end;
except
IdTCPClient1.Disconnect;
end;
end;
var
gReqID: Int32 = 0;
function TForm1.SendRECONPacket(PktType: Int32; const Payload: string = ''): Int32;
var
Bytes: TIdBytes;
begin
Bytes := IndyTextEncoding_ASCII.GetBytes(Payload);
try
if gReqID < MaxInt then Inc(gReqID)
else gReqID := 1;
Result := gReqID;
IdTCPClient1.IOHandler.WriteBufferOpen;
try
IdTCPClient1.IOHandler.Write(Int32(Length(Bytes)+10), False);
IdTCPClient1.IOHandler.Write(Result, False);
IdTCPClient1.IOHandler.Write(PktType, False);
IdTCPClient1.IOHandler.Write(Bytes);
IdTCPClient1.IOHandler.Write(UInt16(0), False);
IdTCPClient1.IOHandler.WriteBufferClose;
except
IdTCPClient1.IOHandler.WriteBufferCancel;
raise;
end;
except
IdTCPClient1.Disconnect;
raise;
end;
end;
function TForm1.SendRECONLogin(const Password: String): Int32;
begin
Result := SendRECONPacket(SERVERDATA_AUTH, Password);
end;
function TForm1.SendRECONCommand(const Cmd: String): Int32;
begin
Result := SendRECONPacket(SERVERDATA_EXECCOMMAND, Cmd);
end;
function TForm1.ReadRECONPacket(var PktType: Integer; var Payload: String): Int32;
var
Len: Int32;
begin
try
Len := IdTCPClient1.IOHandler.ReadInt32(False);
Result := IdTCPClient1.IOHandler.ReadInt32(False);
PktType := IdTCPClient1.IOHandler.ReadInt32(False);
Payload := IdTCPClient1.IOHandler.ReadString(Len-10, IndyTextEncoding_ASCII);
IdTCPClient1.IOHandler.Discard(2);
except
IdTCPClient1.Disconnect;
raise;
end;
end;
Note that RCON is an asynchronous protocol. Each command contains a request ID, which is echoed back in the response. Multiple commands can be sent to the server without waiting for their replies. That is why I wrote SendRCONPacket() to return the request ID actually used, so you can save it off somewhere and match it to the response ID returned by ReadRCONPacket(). The use of a TTimer in the above code is just an example of how to receive unsolicited data from the server. In production code, I would suggest using a dedicated reading thread instead of a timer, and let the thread notify the rest of your code whenever a packet arrives.
If you are not planning on ever having multiple commands being processed in parallel, then you could get rid of the timer altogether and do something more like this instead:
const
SERVERDATA_AUTH = 3;
SERVERDATA_AUTH_RESPONSE = 2;
SERVERDATA_EXECCOMMAND = 2;
SERVERDATA_RESPONSE_VALUE = 0;
procedure TForm1.Button1Click(Sender: TObject);
var
Reply: string;
begin
IdTCPClient1.Host := '127.0.0.1';
IdTCPClient1.Port := 20001;
IdTCPClient1.Connect;
SendRECONLogin('1234');
ShowMessage('Conectado exitosamente');
Reply := SendRECONCommand('say Hello');
// use Reply as needed...
ShowMessage(Reply);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
IdTCPClient1.Disconnect;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
Reply: string;
begin
Reply := SendRECONCommand('list');
// use Reply as needed...
ShowMessage(Reply);
end;
var
gReqID: Int32 = 0;
function TForm1.SendRECONPacket(PktType: Int32; const Payload: string = ''): Int32;
var
Bytes: TIdBytes;
begin
Bytes := IndyTextEncoding_ASCII.GetBytes(Payload);
try
if gReqID < MaxInt then Inc(gReqID)
else gReqID := 1;
Result := gReqID;
IdTCPClient1.IOHandler.WriteBufferOpen;
try
IdTCPClient1.IOHandler.Write(Int32(Length(Bytes)+10), False);
IdTCPClient1.IOHandler.Write(Result, False);
IdTCPClient1.IOHandler.Write(PktType, False);
IdTCPClient1.IOHandler.Write(Bytes);
IdTCPClient1.IOHandler.Write(UInt16(0), False);
IdTCPClient1.IOHandler.WriteBufferClose;
except
IdTCPClient1.IOHandler.WriteBufferCancel;
raise;
end;
except
IdTCPClient1.Disconnect;
raise;
end;
end;
procedure TForm1.SendRECONLogin(const Password: String);
var
ReqID, RespID, PktType: Int32;
Reply: String;
begin
{
From https://developer.valvesoftware.com/wiki/Source_RCON_Protocol#SERVERDATA_AUTH_RESPONSE:
When the server receives an auth request, it will respond with an empty SERVERDATA_RESPONSE_VALUE,
followed immediately by a SERVERDATA_AUTH_RESPONSE indicating whether authentication succeeded or
failed. Note that the status code is returned in the packet id field, so when pairing the response with the
original auth request, you may need to look at the packet id of the preceeding SERVERDATA_RESPONSE_VALUE.
}
// in testing, there is no empty SERVERDATA_RESPONSE_VALUE sent before SERVERDATA_AUTH_RESPONSE!
ReqID := SendRECONPacket(SERVERDATA_AUTH, Password);
RespID := ReadRECONPacket(PktType, Reply);
if PktType = SERVERDATA_RESPONSE_VALUE then
begin
if RespID <> ReqID then
raise Exception.Create('Received unexpected packet');
RespID := ReadRECONPacket(PktType, Reply);
end;
if PktType <> SERVERDATA_AUTH_RESPONSE then
raise Exception.Create('Received unexpected packet');
if RespID <> ReqID then
begin
if RespID <> -1 then
raise Exception.Create('Received unexpected packet');
raise Exception.Create('Authentication failed');
end;
end;
function TForm1.SendRECONCommand(const Cmd: String): string;
var
ReqID, TermReqID, RespID, PktType: Int32;
Reply: string;
begin
{
From https://developer.valvesoftware.com/wiki/Source_RCON_Protocol#Multiple-packet_Responses:
Most responses are small enough to fit within the maximum possible packet size of 4096 bytes.
However, a few commands such as cvarlist and, occasionally, status produce responses too
long to be sent in one response packet. When this happens, the server will split the response
into multiple SERVERDATA_RESPONSE_VALUE packets. Unfortunately, it can be difficult to
accurately determine from the first packet alone whether the response has been split.
One common workaround is for the client to send an empty SERVERDATA_RESPONSE_VALUE
packet after every SERVERDATA_EXECCOMMAND request. Rather than throwing out the
erroneous request, SRCDS mirrors it back to the client, followed by another RESPONSE_VALUE
packet containing 0x0000 0001 0000 0000 in the packet body field. Because SRCDS always
responds to requests in the order it receives them, receiving a response packet with an empty
packet body guarantees that all of the meaningful response packets have already been received.
Then, the response bodies can simply be concatenated to build the full response.
}
// in testing, there is no mirrored SERVERDATA_RESPONSE_VALUE! The sent SERVERDATA_RESPONSE_VALUE
// is responded with a single SERVERDATA_RESPONSE_VALUE that says 'Unknown request' in its payload!
ReqID := SendRECONPacket(SERVERDATA_EXECCOMMAND, Cmd);
TermReqID := SendRECONPacket(SERVERDATA_RESPONSE_VALUE, '');
repeat
RespID := ReadRECONPacket(PktType, Reply);
if PktType <> SERVERDATA_RESPONSE_VALUE then
raise Exception.Create('Received unexpected packet');
if RespID <> ReqID then
begin
if RespID <> TermReqID then
raise Exception.Create('Received unexpected packet');
{
RespID := ReadRECONPacket(PktType, Reply);
if (PktType <> SERVERDATA_RESPONSE_VALUE) or (RespID <> TermReqID) then
raise Exception.Create('Received unexpected packet');
}
Break;
end;
Result := Result + Reply;
until False;
end;
function TForm1.ReadRECONPacket(var PktType: Integer; var Payload: String): Int32;
var
Len: Int32;
begin
try
Len := IdTCPClient1.IOHandler.ReadInt32(False);
Result := IdTCPClient1.IOHandler.ReadInt32(False);
PktType := IdTCPClient1.IOHandler.ReadInt32(False);
Payload := IdTCPClient1.IOHandler.ReadString(Len-10, IndyTextEncoding_ASCII);
IdTCPClient1.IOHandler.Discard(2);
except
IdTCPClient1.Disconnect;
raise;
end;
end;

Related

how do I disconnect inactive clients with TIdTCPServer?

I am trying to disconnect inactive clients that are connected to TIdTCPServer, whether those clients are disconnected from their Internet or for a period of inactive time.
I tried to set timeouts in the OnConnect event like the following:
procedure TservForm.TcpServerConnect(AContext: TIdContext);
begin
AContext.Connection.IOHandler.ReadTimeout := 26000;
AContext.Binding.SetSockOpt(Id_SOL_SOCKET, Id_SO_SNDTIMEO, 15000);
end;
But it seems a disconnect is not triggered after the client connection is lost.
I tried to use SetKeepAliveValues(), but it takes too much time to get an inactive client disconnected.
Is there a more helpful way to disconnect inactive clients? So if the client did not receive or send anything, for example in 30 seconds, the server will disconnect it?
on execute event
procedure TservForm.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
cmd: String;
Cache, OutboundCmds: TStringList;
MS: TMemoryStream;
I: integer;
S: String;
begin
Connection := AContext as TConnection;
// check for pending outbound commands...
OutboundCmds := nil;
try
Cache := Connection.OutboundCache.Lock;
try
if Cache.Count > 0 then
begin
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
end;
finally
Connection.OutboundCache.Unlock;
end;
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
AContext.Connection.IOHandler.Writeln(OutboundCmds.Strings[I],
IndyTextEncoding_UTF8);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
AContext.Connection.IOHandler.LargeStream := true;
AContext.Connection.IOHandler.Write(MS, 0, true);
end;
end;
end;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
OutboundCmds.Objects[I].Free;
end;
OutboundCmds.Free;
end;
// check for a pending inbound command...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
Exit;
end;
end;
cmd := AContext.Connection.Socket.ReadLn(IndyTextEncoding_UTF8);
...............
...............
The client does not disconnect because the ReadLn() is not reached during idle times, so the ReadTimeout does not have effect, and if you are not sending a lot of commands then the socket buffer is not filling up so SO_SNDTIMEO does not have an effect, either.
Since you are already doing some manual timeout handling, you can expand on it to handle an idle timeout as well, eg:
type
TConnection = class(TIdServerContext)
...
public
LastSendRecv: LongWord;
...
end;
...
procedure TservForm.TcpServerConnect(AContext: TIdContext);
var
Connection: TConnection;
begin
Connection := AContext as TConnection;
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
AContext.Connection.IOHandler.LargeStream := True;
AContext.Connection.IOHandler.ReadTimeout := 30000;
AContext.Binding.SetSockOpt(Id_SOL_SOCKET, Id_SO_SNDTIMEO, 15000);
Connection.LastSendRecv := Ticks;
end;
procedure TservForm.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
cmd: String;
Cache, OutboundCmds: TStringList;
MS: TMemoryStream;
I: integer;
S: String;
begin
Connection := AContext as TConnection;
// check for pending outbound commands...
OutboundCmds := nil;
try
Cache := Connection.OutboundCache.Lock;
try
if Cache.Count > 0 then
begin
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
end;
finally
Connection.OutboundCache.Unlock;
end;
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
AContext.Connection.IOHandler.WriteLn(OutboundCmds.Strings[I]);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
AContext.Connection.IOHandler.Write(MS, 0, true);
end;
Connection.LastSendRecv := Ticks;
end;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
OutboundCmds.Objects[I].Free;
end;
OutboundCmds.Free;
end;
// check for a pending inbound command...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
if GetTickDiff(Connection.LastSendRecv, Ticks) >= 30000 then
AContext.Connection.Disconnect;
Exit;
end;
end;
cmd := AContext.Connection.Socket.ReadLn;
Connection.LastSendRecv := Ticks;
...
end;

Indy : Treatment when connection between server and clients will be broken abnormally

Everyone.
I am developing Server/Clients program on based Indy TCP controls.
Now, I faced some uncertain problems..
It's just about the connection broken abnormally...
Let us suppose network status is broken unexpectedly, or Server application is terminated abnormally, so client can't communicate with server anymore...
then clients will occure exceptions like as "connection reset by peer" or "connection refused..."
In these cases, how to treate these exceptions smartly ?
I want that client will connect again automatically and communicate normally after recovering of server status...
If you have a good idea, please share it.....
Below is my code. I have used two timer controls. One is to send alive and confirm networks status(5000ms). If network status is ok, then this timer is dead, and another timer is enable. Second timer is to send info to server(1000ms)
If in second timer, exception occures then it's disabled, and the 1st timer is enabled again.
when "connection refused" is occured, then try except block can catch it.
But if "Connection reset by peer" is occured, then try except block can't catch it.
{sendbuffer funtion}
function SendBuffer(AClient: TIdTCPClient; ABuffer: TBytes): Boolean; overload;
begin
try
Result := True;
try
AClient.IOHandler.Write(LongInt(Length(ABuffer)));
AClient.IOHandler.WriteBufferOpen;
AClient.IOHandler.Write(ABuffer, Length(ABuffer));
AClient.IOHandler.WriteBufferFlush;
finally
AClient.IOHandler.WriteBufferClose;
end;
except
Result := False;
end;
end;
{alive timer}
procedure TClientForm.Timer_StrAliveTimer(Sender: TObject);
var
infoStr : string;
begin
if not IdTCPClient_StrSend.Connected then
begin
try
if IdTCPClient_StrSend.IOHandler <> nil then
begin
IdTCPClient_StrSend.IOHandler.InputBuffer.Clear;
IdTCPClient_StrSend.IOHandler.WriteBufferClear;
end;
IdTCPClient_StrSend.Connect;
except on E: Exception do
begin
SAOutMsg := 'connect fail : ' + E.ToString ;
Exit;
end;
end;
SAOutMsg := 'connect success : ';
if IdTCPClient_StrSend.Connected then
begin
IdTCPClient_StrSend.IOHandler.CheckForDisconnect(True, True);
IdTCPClient_StrSend.IOHandler.CheckForDataOnSource(100);
infoStr := MY_MAC_ADDRESS+'|'+MY_COMPUTER_NAME;
try
IdTCPClient_StrSend.IOHandler.WriteLn(infoStr, nil);
except on E: Exception do
begin
SAOutMsg := 'login info send fail : ';
Exit;
end;
end;
SAOutMsg := 'login info send success : ';
try
if IdTCPClient_StrSend.IOHandler.ReadLn() = 'OK' then
begin
Timer_StrAlive.Enabled := False;
Timer_Str.Enabled := True;
end;
except on E: Exception do
begin
SAOutMsg := 'login fail : ' + E.ToString ;
Exit;
end;
end;
SAOutMsg := 'login ok : ' ;
end;
end;
end;
{send part}
procedure TClientForm.Timer_StrTimer(Sender: TObject);
var
LBuffer: TBytes;
LClientRecord: TClientRecord;
begin
// IdTCPClient_StrSend.CheckForGracefulDisconnect(False);
if not IdTCPClient_StrSend.Connected then
begin
Timer_Str.Enabled := False;
Timer_StrAlive.Enabled := True;
Exit;
end;
if IdTCPClient_StrSend.Connected then
begin
LClientRecord.data1 := str1;
LClientRecord.data2:= Trim(str2);
LClientRecord.data3 := Trim(str3);
LBuffer := MyRecordToByteArray(LClientRecord);
IdTCPClient_StrSend.IOHandler.CheckForDisconnect(True, True);
IdTCPClient_StrSend.IOHandler.CheckForDataOnSource(100);
if (SendBuffer(IdTCPClient_StrSend, LBuffer) = False) then
begin
SOutMsg := 'info send fail' ;
IdTCPClient_StrSend.Disconnect(False);
if IdTCPClient_StrSend.IOHandler <> nil then
IdTCPClient_StrSend.IOHandler.InputBuffer.Clear;
Timer_Str.Enabled := False;
Timer_StrAlive.Enabled := True;
Exit;
end
Exceptions related to lost connections, like "connection reset by peer", do not occur until you perform a socket read/write operation after the OS has detected the lost connection (usually after an internal timeout period has elapsed) and invalidated the socket connection. Most Indy client components do not perform such operations automatically, you have to tell them to do so (TIdTelnet and TIdCmdTCPClient being notable exceptions to that rule, as they run internal reading threads). So simply wrap your socket operations in a try/except block, and if you catch an Indy socket exception (EIdSocketError or descendant, for instance) then you can call Disconnect() and Connect() to re-connect.
"connection refused" can only occur when calling Connect(). It usually means the server was reached but could not accept the connection at that time, either because there is no listening socket on the requested IP/port, or there are too many pending connections in the listening socket's backlog (it could also mean a firewall blocked the connection). Again, simply wrap Connect() in a try/except to handle the error so you can call Connect() again. You should wait a small timeout period before doing so, to allow the server some time to possibly clear up whatever condition made it refuse the connection in the first place (assuming a firewall is not the issue).
Indy relies heavily on exceptions for error reporting, and to a lesser degree for status reporting. So you usually need to make use of try/except handlers when using Indy.
Update: I see a few problems in your code. SendBuffer() is not implementing writing buffering correctly. And most of the calls to Connected(), and all of the calls to CheckForDisconnect() and CheckForDataOnSource(), are overkill and should be removed completely. The only calls that make sense to keep are the first call to Connected() in each timer.
Try something more like this:
{sendbuffer function}
function SendBuffer(AClient: TIdTCPClient; const ABuffer: TBytes): Boolean; overload;
begin
Result := False;
try
AClient.IOHandler.WriteBufferOpen;
try
AClient.IOHandler.Write(LongInt(Length(ABuffer)));
AClient.IOHandler.Write(ABuffer);
AClient.IOHandler.WriteBufferClose;
except
AClient.IOHandler.WriteBufferCancel;
raise;
end;
Result := True;
except
end;
end;
{alive timer}
procedure TClientForm.Timer_StrAliveTimer(Sender: TObject);
var
infoStr : string;
begin
if IdTCPClient_StrSend.Connected then Exit;
try
IdTCPClient_StrSend.Connect;
except
on E: Exception do
begin
SAOutMsg := 'connect fail : ' + E.ToString;
Exit;
end;
end;
try
SAOutMsg := 'connect success : ';
infoStr := MY_MAC_ADDRESS+'|'+MY_COMPUTER_NAME;
try
IdTCPClient_StrSend.IOHandler.WriteLn(infoStr);
except
on E: Exception do
begin
E.Message := 'login info send fail : ' + E.Message;
raise;
end;
end;
SAOutMsg := 'login info send success : ';
try
if IdTCPClient_StrSend.IOHandler.ReadLn() <> 'OK' then
raise Exception.Create('not OK');
except
on E: Exception do
begin
E.Message := 'login fail : ' + E.Message;
raise;
end;
end;
SAOutMsg := 'login ok : ' ;
except
on E: Exception do
begin
SAOutMsg := E.ToString;
IdTCPClient_StrSend.Disconnect(False);
if IdTCPClient_StrSend.IOHandler <> nil then
IdTCPClient_StrSend.IOHandler.InputBuffer.Clear;
Exit;
end;
end;
Timer_StrAlive.Enabled := False;
Timer_Str.Enabled := True;
end;
{send part}
procedure TClientForm.Timer_StrTimer(Sender: TObject);
var
LBuffer: TBytes;
LClientRecord: TClientRecord;
begin
if not IdTCPClient_StrSend.Connected then
begin
Timer_Str.Enabled := False;
Timer_StrAlive.Enabled := True;
Exit;
end;
LClientRecord.data1 := str1;
LClientRecord.data2:= Trim(str2);
LClientRecord.data3 := Trim(str3);
LBuffer := MyRecordToByteArray(LClientRecord);
if not SendBuffer(IdTCPClient_StrSend, LBuffer) then
begin
SOutMsg := 'info send fail' ;
IdTCPClient_StrSend.Disconnect(False);
if IdTCPClient_StrSend.IOHandler <> nil then
IdTCPClient_StrSend.IOHandler.InputBuffer.Clear;
Timer_Str.Enabled := False;
Timer_StrAlive.Enabled := True;
Exit;
end
...
end;
Now, with that said, using Indy inside of timers in the main UI thread is not the best, or even the safest, way to use Indy. This kind of logic would work much better in a worker thread instead, eg:
type
TStrSendThread = class(TThread)
private
FClient: TIdTCPClient;
...
protected
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(AClient: TIdTCPClient); reintroduce;
end;
constructor TStrSendThread.Create(AClient: TIdTCPClient);
begin
inherited Create(False);
FClient := AClient;
end;
procedure TStrSendThread.Execute;
var
LBuffer: TIdBytes;
...
begin
while not Terminated do
begin
Sleep(ConnectInterval);
if Terminated then Exit;
try
FClient.Connect;
try
// report status to main thread as needed...
FClient.IOHandler.WriteLn(MY_MAC_ADDRESS+'|'+MY_COMPUTER_NAME);
if FClient.IOHandler.ReadLn() <> 'OK' then
raise Exception.Create('error message');
// report status to main thread as needed...
while not Terminated do
begin
Sleep(SendInterval);
if Terminated then Exit;
...
if not SendBuffer(FClient, LBuffer) then
raise Exception.Create('error message');
end;
finally
FClient.FDisconnect(False);
if FClient.IOHandler <> nil then
FClient.IOHandler.InputBuffer.Clear;
end;
except
on E: Exception do
begin
// report error to main thread as needed...
end;
end;
end;
end;
procedure TStrSendThread.DoTerminate;
begin
// report status to main thread as needed...
inherited;
end;
private
Thread: TStrSendThread;
...
// Timer_StrAliveTimer.Active := True;
if Thread = nil then
Thread := TStrSendThread.Create(IdTCPClient_StrSend);
...
// Timer_StrAliveTimer.Active := False;
if Thread <> nil then
begin
Thread.Terminate;
Thread.WaitFor;
FreeAndNil(Thread);
end;

Using Indy TCPClient/TCPServer to send picture from mobile XE8

I have a simple mobile application written in Delphi XE8 that allows the user to take a picture and then send the picture to a server using Indy TCPClient/TCP Server.
I have scoured the forums and found numerous examples to send the data in a variety of ways. Every method I try results in an access violation or corrupt data on the server side.
My ultimate goal is to send a record containing a unique identifier, description and a picture(bitmap) from the client to the server.
But I'm starting out be trying to simply send a record with some text from a windows client to the server. I will then try to implement the solution into my mobile app.
type
TSendRec = record
// SONo: string;
Text: string;
// Bitmap: TBitMap;
end
I have tried the following 3 methods as per the code below:
Send Using a Stream
Send using RawToBytes and TIDBytes.
Send a line of text using Writeln and Readln
When I try to send using a stream I get the following access violation:
Project memorystream_server.exe raised the exception class $C0000005 with message 'access violation at 0x00409e46: write of address 0x0065d1bc
The error occurs when I try to access the value of MiRec.Text on the server side.
Memo1.Lines.Add(MiRec.Text);
So I assume the read of the MIRec is failing for some reason:
When I send using RawToBytes, no error message occurs but the value of MIRec.Text is garbage.
When I just send a line of text using WriteLn, the server receives and displays the data correctly and no access violation occurs.
I tried to follow examples that I have found from other posts on this issue. I would greatly appreciate any insight into what I am doing wrong.
Following are my client and server side code snippets:
Client
procedure TfrmMemoryStreamClient.btnSendClick2(Sender: TObject);
var
Buffer: TIdBytes;
MIRec: TSendRec;
msRecInfo: TMemoryStream;
msRecInfo2: TIdMemoryBufferStream;
begin
IdTCPClient1.Connect;
MIRec.Text := 'Hello World';
if rbSendStream.Checked then
begin
msRecInfo := TMemoryStream.Create;
try
msRecInfo.Write(MIRec, SizeOf(MIRec));
IdTCPClient1.IOHandler.Write(msRecInfo, 0, False);
finally
msRecInfo.Free;
end;
{
msRecInfo2 := TIdMemoryBufferStream.Create(#MIRec, SizeOf(TSendRec));
try
IdTCPClient1.IOHandler.Write(msRecInfo2);
finally
msRecInfo.Free;
end;
}
end
else
if rbSendBytes.Checked then
begin
Buffer := RawToBytes(MIRec, SizeOf(MIRec));
IdTCPClient1.IOHandler.Write(Buffer);
end
else
if rbWriteLn.Checked then
begin
IdTCPClient1.Socket.WriteLn(Edit1.Text);
end;
IdTCPClient1.DisConnect;
end;
Server
procedure TStreamServerForm.IdTCPServer1Execute(AContext: TIdContext);
var sName: String;
MIRec: TSendRec;
Buffer: TIdBytes;
msRecInfo: TMemoryStream;
begin
if not chkReceiveText.Checked then
begin
try
if chkReadBytes.Checked then
begin
AContext.Connection.IOHandler.ReadBytes(Buffer, SizeOf(MIRec));
BytesToRaw(Buffer, MIRec, SizeOf(MIRec));
Memo1.Lines.Add(MiRec.Text);
end
else
begin
msRecInfo := TMemoryStream.Create;
try
// does not read the stream size, just the stream data
AContext.Connection.IOHandler.ReadStream(msRecInfo, SizeOf(MIRec), False);
msRecInfo.Position := 0;
msRecInfo.Read(MIRec, SizeOf(MIRec));
Memo1.Lines.Add(MiRec.Text);
finally
msRecInfo.Free;
end;
{
AContext.Connection.IOHandler.ReadStream(msRecInfo, -1, False);
msRecInfo.Position := 0;
msRecInfo.Read(MIRec, SizeOf(MIRec));
Memo1.Lines.Add(MiRec.Text);
}
end;
Memo1.Lines.Add('read File');
except
Memo1.Lines.Add('error in read File');
end;
end
else
begin
sName := AContext.Connection.Socket.ReadLn;
Memo1.Lines.Add(sName);
end;
AContext.Connection.Disconnect;
end;
TIdTCPServer is a multithreaded component. Its OnConnect, OnDisconnect, and OnExecute events are triggered in the context of a worker thread. As such, you MUST synchronize with the main UI thread when accessing UI controls, like your Memo.
Also, String is a compiler-managed data type, and TBitmap is an object. Both store their data elsewhere in memory, so you cannot write a record containing such fields as-is. You would be writing only the value of their data pointers, not writing the actual data being pointed at. You need to serialize your record into a transmittable format on the sending side, and then deserialize it on the receiving side. That means handling the record fields individually.
Try something more like this:
type
TSendRec = record
SONo: string;
Text: string;
Bitmap: TBitMap;
end;
Client
procedure TfrmMemoryStreamClient.btnSendClick2(Sender: TObject);
var
MIRec: TSendRec;
ms: TMemoryStream;
begin
MIRec.SONo := ...;
MIRec.Text := 'Hello World';
MIRec.Bitmap := TBitmap.Create;
...
try
IdTCPClient1.Connect;
try
IdTCPClient1.IOHandler.WriteLn(MIRec.SONo);
IdTCPClient1.IOHandler.WriteLn(MIRec.Text);
ms := TMemoryStream.Create;
try
MIRec.Bitmap.SaveToStream(ms);
IdTCPClient1.IOHandler.LargeStream := True;
IdTCPClient1.IOHandler.Write(ms, 0, True);
finally
ms.Free;
end;
finally
IdTCPClient1.Disconnect;
end;
finally
MIRec.Bitmap.Free;
end;
end;
Server
procedure TStreamServerForm.IdTCPServer1Execute(AContext: TIdContext);
var
MIRec: TSendRec;
ms: TMemoryStream;
begin
MIRec.SONo := AContext.Connection.IOHandler.ReadLn;
MIRec.Text := AContext.Connection.IOHandler.ReadLn;
MIRec.Bitmap := TBitmap.Create;
try
ms := TMemoryStream.Create;
try
AContext.Connection.IOHandler.LargeStream := True;
AContext.Connection.IOHandler.ReadStream(ms, -1, False);
ms.Position := 0;
MIRec.Bitmap.LoadFromStream(ms);
finally
ms.Free;
end;
TThread.Synchronize(nil,
procedure
begin
Memo1.Lines.Add(MIRec.SONo);
Memo1.Lines.Add(MIRec.Text);
// display MIRec.Bitmap as needed...
end;
end;
finally
MIRec.Bitmap.Free;
end;
end;
Alternatively:
Client
procedure TfrmMemoryStreamClient.btnSendClick2(Sender: TObject);
var
MIRec: TSendRec;
ms: TMemoryStream;
procedure SendString(const S: String);
var
Buf: TIdBytes;
begin
Buf := IndyTextEncoding_UTF8.GetBytes(S);
IdTCPClient1.IOHandler.Write(Int32(Length(Buf)));
IdTCPClient1.IOHandler.Write(Buf);
end;
begin
MIRec.SONo := ...;
MIRec.Text := 'Hello World';
MIRec.Bitmap := TBitmap.Create;
...
try
IdTCPClient1.Connect;
try
SendString(MIRec.SONo);
SendString(MIRec.Text);
ms := TMemoryStream.Create;
try
MIRec.Bitmap.SaveToStream(ms);
IdTCPClient1.IOHandler.LargeStream := True;
IdTCPClient1.IOHandler.Write(ms, 0, True);
finally
ms.Free;
end;
finally
IdTCPClient1.Disconnect;
end;
finally
MIRec.Bitmap.Free;
end;
end;
Server
procedure TStreamServerForm.IdTCPServer1Execute(AContext: TIdContext);
var
MIRec: TSendRec;
ms: TMemoryStream;
function RecvString: String;
begin
Result := AContext.Connection.IOHandler.ReadString(
AContext.Connection.IOHandler.ReadInt32,
IndyTextEncoding_UTF8);
end;
begin
MIRec.SONo := RecvString;
MIRec.Text := RecvString;
MIRec.Bitmap := TBitmap.Create;
try
ms := TMemoryStream.Create;
try
AContext.Connection.IOHandler.ReadStream(ms, -1, False);
ms.Position := 0;
MIRec.Bitmap.LoadFromStream(ms);
finally
ms.Free;
end;
TThread.Synchronize(nil,
procedure
begin
Memo1.Lines.Add(MIRec.SONo);
Memo1.Lines.Add(MIRec.Text);
// display MIRec.Bitmap as needed...
end;
end;
finally
MIRec.Bitmap.Free;
end;
end;

Delphi TCPClient Issue

I am new to Delphi and trying to convert vb.net apps to learn. The issue I am having is reading from a TCP/IP host. Currently I can connect via telnet to the device, send a command, and the device will send data non-stop until all data is sent. This could be simply two characters followed by CR/LF, or it could be several rows of varing length data. Each row is end is CR/LF. Prior to writing code, we were able to telnet via Hyperterminal to the device. Send a command, and, with the capture text enabled save to a text file.
Below is the code I have so far. I have not coded for saving to text file (one step at a time). The data is pipe delimited. I have no control on the format or operatation of the device aside from sending commands and receiving data. It works most of the time however there are times when not all of the data (65 records for testing) are received. I will greatly appreciate guidence and feel free to comment on my code, good or bad.
function Parse(Char, S: string; Count: Integer): string;
var
I: Integer;
T: string;
begin
if S[Length(S)] <> Char then
S := S + Char;
for I := 1 to Count do
begin
T := Copy(S, 0, Pos(Char, S) - 1);
S := Copy(S, Pos(Char, S) + 1, Length(S));
end;
Result := T;
end;
procedure TForm2.btnEXITClick(Sender: TObject);
begin
if idTcpClient1.connected then
begin
idTcpClient1.IOHandler.InputBuffer.clear;
idTcpClient1.Disconnect;
end;
Close;
end;
procedure TForm2.btnSendDataClick(Sender: TObject);
var
mTXDataString : String;
RXString : String;
begin
IdTCPClient1.Host := IPAddress.Text;
IdTCPClient1.Port := StrToInt(IPPort.Text);
mTXDataString := mTXData.Text + #13#10;
IdTCPClient1.Connect;
If IdTCPClient1.Connected then
begin
IdTCPClient1.IOHandler.Write(mTXDataString);
mTXDataString := mTXData.Lines.Text;
if MTXDataString.Contains('SCHEMA') then
begin
mRXData.Lines.Add(IdTCPClient1.IOHandler.ReadLn);
while not (IdTCPClient1.IOHandler.InputBufferIsEmpty) do
begin
RXString := IdTCPClient1.IOHandler.ReadLn;
If (RXString <> '') and (RXString <> '??') then
begin
//Add received data to RXmemo
mRXData.Lines.Add(RXString);
//Determine number of records to received based on schema data
lblRecords.Caption := Parse(',', RXString, 2);
end;
end; //while not
end // if
else
if mTXDataString.Contains('DATA') then
begin
mRXData.Lines.Add(IdTCPClient1.IOHandler.ReadLn);
while not (IdTCPClient1.IOHandler.InputBufferIsEmpty) do
begin
RXString := IdTCPClient1.IOHandler.ReadLn;
If (RXString <> '') and (RXString <> '??') then
begin
mRXData.Lines.Add(RXString);
end; // if
end; //while not
end; // if Schema or not
end; // if Connected
IdTCPClient1.Disconnect;
end; //Procedure
HyperTerminal and Telnet apps display whatever data they receive, in real-time. TIdTCPClient is not a real-time component. You control when and how it reads. If you are expecting data to arrive asynchronously, especially if you don't know how many rows are going to be received, then you need to perform the reading in a timer or worker thread, eg:
procedure TForm2.TimerElapsed(Sender: TObject);
var
S: String;
begin
if IdTCPClient1.IOHandler = nil then Exit;
if IdTCPClient1.IOHandler.InputBufferIsEmpty then
begin
IdTCPClient1.IOHandler.CheckForDataOnSource(50);
if IdTCPClient1.IOHandler.InputBufferIsEmpty then Exit;
end;
S := IdTCPClient1.IOHandler.ReadLn;
// use S as needed ...
end;
Or:
type
TMyThread = class(TThread)
protected
fClient: TIdTCPClient;
procedure Execute; override;
public
constructor Create(aClient: TIdTCPClient);
end;
constructor TMyThread.Create(aClient: TIdTCPClient);
begin
inherited Create(False);
fClient := aClient;
end;
procedure TMyThread.Execute;
var
S: String;
begin
while not Terminated do
begin
S := fClient.IOHandler.ReadLn;
// use S as needed ...
end;
end;
Or, if the server supports the actual Telnet protocol, have a look at using Indy's TIdTelnet component instead.

Multi-Byte Character Support over TServerSocket Delphi

While working on a multi-user chat application I've got stuck around getting the multi-byte chars to work over TServerSocket / TClientSocket.
This is the part where the client sends the message to the server:
procedure TChatForm.SendBtnClick(Sender: TObject);
var str : string;
begin
str := MsgLabel.Text;
ClientSocket.Socket.SendText('message' + separator + nickname + separator + str);
MsgLabel.Text := '';
add_text(MsgBox,MsgLabel,nickname+': '+str,'none');
end;
This is how the server parses the received data:
procedure TServerForm.ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
var
i,hnd : Integer;
recv : string;
arr : TStringArray; // type TStringArray = array of string;
begin
recv := Socket.ReceiveText;
hnd := Socket.Handle; //using this to avoid sending received data back to the client
arr := SplitStr(recv,separator);
//SplitStr is a function i use because TStringList.DelimitedText uses only a char as delimiter
// sending the data to the others users / but the expeditor - async error workaround
for i:=0 to ServerSocket.Socket.ActiveConnections-1 do begin
if ServerSocket.Socket.Connections[i].Handle <> hnd then
ServerSocket.Socket.Connections[i].SendText(recv);
end;
if arr[0] = 'connect' then begin
// adding the connected user to the tlistbox
Contacts.Items.Add(arr[1]);
// adding the connected message in the trichedit
add_text(MsgBox,SendMsg,arr[1]+' has connected !','green');
end else if arr[0] = 'disconnect' then begin
// removing the user from the online user list
Contacts.Items.Delete(Contacts.Items.IndexOf(arr[1]));
// adding the disconnected message in trichedit
add_text(MsgBox,SendMsg,arr[1]+' has disconnected !','red');
end else if arr[0] = 'message' then begin
// finally adding the message that user send in the TRichEdit
add_text(MsgBox,SendMsg,arr[1]+': '+arr[2],'none');
end;
end;
An example of how the Socket.ReceiveText looks like:
- when user connects he sends the next message - connect^SEPARATOR^username
- when a user sends a message - message^SEPARATOR^username^SEPARATOR^message_body
The structure is ACTION + SEPARATOR + USERNAME + EXTRA_DATA, thas my way of "keeping" the online users list updated. I'm new to delphi, if there's any easier way of doing that, let me know.
The problem is now, if I'm sending multibyte characters over to the users and back, those multibyte chars are received as question marks "?".
- "ț or ș" becomes "? or ?"
Printscreen here:
EDIT2: Ok, after all the changes have been made, thanks to your answers, I bumped into a problem while trying to send the data received by the server from the client back to the other clients. Well this problem has 2 little bumps:
This is how the server sends a "global" message to the users.
procedure TServerForm.SendBtnClick(Sender: TObject);
var
i : Integer;
str : String;
begin
str := SendMsg.Text;
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
SendString(Connections[i], TSocketBuffers(Connections[i].Data).OutBuffer, 'global' + separator + str);
end;
add_text(MsgBox,SendMsg,str,'none');
SendMsg.Text := '';
end;
This is how server sends back to other active connections the data received from one client:
procedure TServerForm.ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
var
Buffers: TSocketBuffers;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
Buffers := TSocketBuffers(Socket.Data);
if not Buffers.ReadInData(Socket) then Exit;
Buffers.InBuffer.Position := 0;
try
while ReadString(Buffers.InBuffer, RecvStr) do
begin
arr := SplitStr(RecvStr, separator);
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
begin
if Connections[i] <> Socket then
SendString(Connections[i], TSocketBuffers(Connections[i].Data).OutBuffer, arr[0]);
end;
end;
// [ .. some string processing stuff .. ]
end;
finally
CompactBuffer(Buffers.InBuffer);
end;
end;
Now, if these 2 methods are correct, then the problem is the reading data on the client side, and this is how the data is parsed on the client side following the same principle as ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
procedure TChatForm.ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
Buffers: TSocketBuffers;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
Buffers := TSocketBuffers(Socket.Data);
if not Buffers.ReadInData(Socket) then Exit;
Buffers.InBuffer.Position := 0;
try
while ReadString(Buffers.InBuffer, RecvStr) do begin
ShowMessage(RecvStr); // testing if anything is received
// [[.. some string processing code ..]]
end;
finally
CompactBuffer(Buffers.InBuffer);
end;
end;
Trying to send data from client to server works flawlessly as you can see in the image (above) string is interpreted as it should be. The problem is either trying to send the data back to the clients in ServerSocketClientRead method, either in the ClientSocketRead method.
UPDATE 3: So I had launched the client on another pc and the problem seems to be at the ClientSocketRead method (if the ServerSocketClientRead -> SendString and the global SendBtn -> SendString are correct); I'll keep updating if any new details are found.
You need to stay away from the SendText() and ReceiveText() methods, especially if you are using non-blocking sockets. They do not handle the conditions that data may have to be sent in multiple packets, and that packets can arrive in smaller pieces or even multiple packets merged together. These are very common conditions that you have to handle in TCP programming.
SendText() simply passes the string as-is to SendBuf(). If it cannot send the entire string in a single send, it does not attempt to re-send the remaining characters. So you can (and likely will) send incomplete strings. It does return how many bytes were actually sent, so you can call SendText() in a loop until there are no more characters to send.
ReceiveText() has no way of knowing the length of the string being received. It merely reads whatever is currently in the socket buffer and returns it as a string. So this also runs the risk of reading incomplete strings, or even reading multiple (even partial) strings together.
The best way to send a string is to use SendBuf() and ReceiveBuf() directly instead. When sending a string, either send the string length (in bytes) before sending the string data, or else send a unique delimiter after the string data that does not appear in the string itself. The receiver can then read the length value and then read the specified number of bytes, or read until the delimiter is encountered. Also, when dealing with non-ASCII string data, especially with D2009+'s UnicodeString string type, you should encode the string data to a universal format during transmission, such as UTF-8.
If you are using non-blocking sockets, this gets more complicated. If a socket would enter a blocking state during a send/read operation, the operation fails with an WSAEWOULDBLOCK error code and you have to repeat the operation when the socket is out of the blocking state.
If a send operation fails with WSAEWOULDBLOCK then buffer your remaining data somewhere (and append any future outbound data to the end of that buffer if it is not empty) until the OnWrite event fires, then send whatever is in your buffer, removing successfully sent bytes, until it is emptied or the socket blocks again (in which case, you have to wait for another OnWrite event before sending the remaining buffer data).
Likewise, when a read operation fails with WSAEWOULDBLOCK but you are still expecting data, you have to wait for another OnRead event to fire before you can attempt to read again, buffering any intermediate data that has been received, until you have received all of the data that you are expecting before you can then process it.
For example:
Common code:
type
TSocketData = class
private
Socket: TCustomSocketSocket;
InBuffer: TMemoryStream;
OutBuffer: TMemoryStream;
function SendRawToSocket(Data: Pointer; DataLen: Integer): Integer;
procedure Compact(Buffer: TMemoryStream);
public
constructor Create(ASocket: TCustomSocketSocket);
destructor Destroy; override;
function BufferInboundData: Boolean;
procedure FlushOutboundData;
procedure BeginReading;
procedure EndReading;
function SendRaw(Data: Pointer; DataLen: Integer): Boolean;
function ReadRaw(Data: Pointer; DataLen: Integer): Boolean;
function SendInteger(Value: Integer): Boolean;
function ReadInteger(var Value: Integer): Boolean;
function SendInt64(Value: Int64): Boolean;
function ReadInt64(var Value: Int64): Boolean;
function SendString(const Str: String): Boolean;
function ReadString(var Str: String): Boolean;
function SendStream(Stream: TStream): Boolean;
function ReadStream(Stream: TStream): Boolean;
end;
constructor TSocketData.Create(ASocket: TCustomWinSocket);
begin
inherited;
Socket := ASocket;
InBuffer := TMemoryStream.Create;
OutBuffer := TMemoryStream.Create;
end;
destructor TSocketData.Destroy;
begin
InBuffer.Free;
OutBuffer.Free;
inherited;
end;
function TSocketData.SendRawToSocket(Data: Pointer; DataLen: Integer): Integer;
var
Bytes: PByte;
Ret: Integer;
begin
Result := 0;
Bytes := PByte(Data);
while DataLen > 0 do
begin
Ret := Socket.SendBuf(Bytes^, DataLen);
if Ret < 1 then
begin
if WSAGetLastError = WSAEWOULDBLOCK then Break;
Result := -1;
Exit;
end;
Inc(Bytes, Ret);
Dec(DataLen, Ret);
Inc(Result, Ret);
end;
end;
function TSocketData.BufferInboundData: Boolean;
var
RecvLen, OldSize: Integer;
begin
Result := False;
RecvLen := Socket.ReceiveLength;
if RecvLen < 1 then Exit;
OldSize := InBuffer.Size;
InBuffer.Size := OldSize + RecvLen;
try
RecvLen := Socket.ReceiveBuf((PByte(InBuffer.Memory)+OldSize)^, RecvLen);
if RecvLen < 1 then RecvLen := 0;
except
RecvLen := 0;
end;
InBuffer.Size := OldSize + RecvLen;
if RecvLen = 0 then Exit;
Result := True;
end;
procedure TSocketData.FlushOutboundData;
var
Ret: Integer;
begin
if OutBuffer.Size = 0 then Exit;
Ret := SendRawToSocket(OutBuffer.Memory, OutBuffer.Size);
if Ret < 1 then Exit;
OutBuffer.Position := Ret;
Compact(OutBuffer);
end;
procedure TSocketData.Compact(Buffer: TMemoryStream);
var
Remaining: Integer;
begin
if Buffer.Position = 0 then Exit;
Remaining := Buffer.Size - Buffer.Position;
if Remaining > 0 then
Move((PByte(Buffer.Memory) + Buffer.Position)^, Buffer.Memory^, Remaining);
Buffer.Size := Remaining;
end;
procedure TSocketData.BeginReading;
begin
InBuffer.Position := 0;
end;
procedure TSocketData.EndReading;
begin
Compact(InBuffer);
end;
function TSocketData.SendRaw(Data: Pointer; DataLen: Integer): Boolean;
var
Bytes: PByte;
Ret: Integer;
begin
Bytes := PByte(Data);
if OutBuffer.Size = 0 then
begin
Ret := SendRawToSocket(Bytes, DataLen);
if Ret = -1 then
begin
Result := False;
Exit;
end;
Inc(Bytes, Ret);
Dec(DataLen, Ret);
end;
if DataLen > 0 then
begin
OutBuffer.Seek(0, soEnd);
OutBuffer.WriteBuffer(Bytes^, DataLen);
end;
Result := True;
end;
function TSocketData.ReadRaw(Data: Pointer; DataLen: Integer): Boolean;
begin
Result := False;
if (InBuffer.Size - InBuffer.Position) < DataLen then Exit;
InBuffer.ReadBuffer(Data^, DataLen);
Result := True;
end;
function TSocketData.SendInteger(Value: Integer): Boolean;
begin
Value := htonl(Value);
Result := SendRaw(#Value, SizeOf(Value));
end;
function TSocketData.ReadInteger(var Value: Integer): Boolean;
begin
Result := ReadRaw(#Value, SizeOf(Value));
if Result then Value := ntohl(Value);
end;
type
TInt64Parts = packed record
case Integer of
0: (
LowPart: LongWord;
HighPart: LongWord);
1: (
QuadPart: Int64);
end;
function hton64(AValue: Int64): Int64;
var
LParts: TInt64Parts;
L: LongWord;
begin
LParts.QuadPart := AValue;
L := htonl(LParts.HighPart);
LParts.HighPart := htonl(LParts.LowPart);
LParts.LowPart := L;
Result := LParts.QuadPart;
end;
function ntoh64(AValue: Int64): Int64;
var
LParts: TInt64Parts;
L: LongWord;
begin
LParts.QuadPart := AValue;
L := ntohl(LParts.HighPart);
LParts.HighPart := ntohl(LParts.LowPart);
LParts.LowPart := L;
Result := LParts.QuadPart;
end;
function TSocketData.SendInt64(Value: Int64): Boolean;
begin
Value := hton64(Value);
Result := SendRaw(#Value, SizeOf(Value));
end;
function TSocketData.ReadInt64(var Value: Int64): Boolean;
begin
Result := ReadRaw(#Value, SizeOf(Value));
if Result then Value := ntoh64(Value);
end;
function TSocketData.SendString(const Str: String): Boolean;
var
S: UTF8String;
Len: Integer;
begin
S := UTF8String(Str);
Len := Length(S);
Result := SendInteger(Len);
if Result and (Len > 0) then
Result := SendRaw(PAnsiChar(S), Len);
end;
function TSocketData.ReadString(var Str: String): Boolean;
var
S: UTF8String;
Len: Integer;
begin
Result := False;
Str := '';
if not ReadInteger(Len) then Exit;
if (InBuffer.Size - InBuffer.Position) < Len then
begin
InBuffer.Seek(-SizeOf(Len), soCurrent);
Exit;
end;
if Len > 0 then
begin
SetLength(S, Len);
ReadRaw(PAnsiChar(S), Len);
Str := String(S);
end;
Result := True;
end;
function TSocketData.SendStream(Stream: TStream): Boolean;
var
Buf: array[0..1023] of Byte;
Len: Int64;
NumToSend: Integer;
begin
Len := Stream.Size - Stream.Position;
Result := SendInt64(Len);
if Result and (Len > 0) then
begin
repeat
if Len > SizeOf(Buf) then
NumToSend := SizeOf(Buf)
else
NumToSend := Integer(Len);
Stream.ReadBuffer(Buf[0], NumToSend);
Dec(Len, NumToSend);
Result := SendRaw(#Buf[0], NumToSend);
until (Len = 0) or (not Result);
end;
end;
function TSocketData.ReadStream(Stream: TStream): Boolean;
var
Len: Int64;
begin
Result := False;
if not ReadInt64(Len) then Exit;
if (InBuffer.Size - InBuffer.Position) < Len then
begin
InBuffer.Seek(-SizeOf(Len), soCurrent);
Exit;
end;
if Len > 0 then
Stream.CopyFrom(InBuffer, Len);
Result := True;
end;
Client code:
procedure TChatForm.ClientSocketConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TSocketData.Create(Socket);
end;
procedure TChatForm.ClientSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).Free;
Socket.Data := nil;
end;
procedure TChatForm.ClientSocketWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).FlushOutboundData;
end;
procedure TChatForm.ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
SocketData: TSocketData;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
SocketData := TSocketData(Socket.Data);
if not SocketData.BufferInboundData then Exit;
SocketData.BeginReading;
try
while SocketData.ReadString(RecvStr) do begin
ShowMessage(RecvStr); // testing if anything is received
// [[.. some string processing code ..]]
end;
finally
SocketData.EndReading;
end;
end;
procedure TChatForm.SendBtnClick(Sender: TObject);
var
SocketData: TSocketData;
begin
if ClientSocket1.Socket = nil then Exit;
SocketData := TSocketData(ClientSocket1.Socket.Data);
if SocketData = nil then Exit;
str := MsgLabel.Text;
if SocketData.SendString('message' + separator + nickname + separator + str) then
begin
MsgLabel.Text := '';
add_text(MsgBox, MsgLabel, nickname + ': ' + str, 'none');
end;
end;
Server code:
procedure TServerForm.ServerSocketClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TSocketData.Create(Socket);
end;
procedure TServerForm.ServerSocketClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).Free;
Socket.Data := nil;
end;
procedure TServerForm.ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
var
SocketData: TSocketData;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
SocketData := TSocketData(Socket.Data);
if not SocketData.BufferInboundData then Exit;
SocketData.BeginReading;
try
while SocketData.ReadString(RecvStr) do
begin
arr := SplitStr(RecvStr, separator);
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
begin
if Connections[i] <> Socket then
TSocketData(Connections[i].Data).SendString(RecvStr);
end;
end;
if arr[0] = 'connect' then
begin
Contacts.Items.Add(arr[1]);
add_text(MsgBox, SendMsg, arr[1] + ' has connected !', 'green');
end
else if arr[0] = 'disconnect' then
begin
Contacts.Items.Delete(Contacts.Items.IndexOf(arr[1]));
add_text(MsgBox, SendMsg, arr[1] + ' has disconnected !', 'red');
end
else if arr[0] = 'message' then
begin
add_text(MsgBox, SendMsg, arr[1] + ': ' + arr[2], 'none');
end;
end;
finally
SocketData.EndReading;
end;
end;
procedure TServerForm.ServerSocketClientWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).FlushOutboundData;
end;
procedure TServerForm.SendBtnClick(Sender: TObject);
var
i : Integer;
str : String;
begin
str := SendMsg.Text;
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
TSocketData(Connections[i].Data).SendString('global' + separator + str);
end;
add_text(MsgBox, SendMsg, str, 'none');
SendMsg.Text := '';
end;

Resources