unit TCPIPServer;
{$optimization off}
{$mode objfpc}{$H+}
interface
uses classes, sockets, baseunix;
const
FUNC_CODE_SOCKET = 1;
FUNC_CODE_BIND = 2;
FUNC_CODE_LISTEN = 3;
FUNC_CODE_ACCEPT = 4;
FUNC_CODE_RECV = 5;
FUNC_CODE_SEND = 6;
type
callback_procedure = procedure(c: pointer);
TTCPIPServerCommArgs = record
socket_to_listen: longint;
client_index: longint;
bufsize: longword;
client_received_callback: callback_procedure;
client_error_callback: callback_procedure;
client_closed_callback: callback_procedure;
client_sent_callback: callback_procedure;
end;
PTCPIPServerCommArgs = ^TTCPIPServerCommArgs;
TTCPIPServerArgs = record
port: word;
backlog: byte;
bufsize: longword;
client_created_callback: callback_procedure;
client_received_callback: callback_procedure;
client_error_callback: callback_procedure;
client_closed_callback: callback_procedure;
client_sent_callback: callback_procedure;
end;
PTCPIPServerArgs = ^TTCPIPServerArgs;
TTCPIPServerCommThread = class(TThread)
private
protected
ts0, ts1: timespec;
ListenSocket: longint;
ClientAddr: TInetSockAddr;
ClientAddrSize: LongInt;
ClientSocket: Longint;
c_client_index: longint;
outBuf: pbyte;
outBufSize: longword;
Buffer: pbyte;
c_BufferContentSize: longword;
CLIENT_BUFFER_SIZE: longword;
ERROR_FUNC_CODE, SOCKET_ERROR_CODE: longint;
FDS: TFDSet;
c_client_received_callback: callback_procedure;
c_client_error_callback: callback_procedure;
c_client_closed_callback: callback_procedure;
c_client_sent_callback: callback_procedure;
procedure Execute; override;
public
Constructor Create(args: PTCPIPServerCommArgs);
function ClientIndex: LongInt;
procedure GetLastError(func_error: plongint; socket_error: plongint);
procedure FreeBuffer;
procedure RecvAck;
function BufferContentSize: longword;
function BufferPointer: pbyte;
procedure Send(buf: pbyte; size: longword);
function OutBufferEmpty: boolean;
procedure FinishClient(HaltTime: longword);
end;
PTCPIPServerCommThread = ^TTCPIPServerCommThread;
TTCPIPServerThread = class(TThread)
private
protected
ts0, ts1: timespec;
srv_port: word;
srv_backlog: byte;
ListenSocket: longint;
ServerAddr: TInetSockAddr;
clients: array of TTCPIPServerCommThread;
client_count: longint;
thrargs: TTCPIPServerCommArgs;
FDS: TFDSet;
ERROR_FUNC_CODE, SOCKET_ERROR_CODE: longint;
CLIENT_BUFFER_SIZE: longword;
last_client: longint;
srv_client_created_callback: callback_procedure;
srv_client_received_callback: callback_procedure;
srv_client_error_callback: callback_procedure;
srv_client_closed_callback: callback_procedure;
srv_client_sent_callback: callback_procedure;
procedure Execute; override;
public
Constructor Create(args: PTCPIPServerArgs);
procedure GetLastError(func_error: plongint; socket_error: plongint);
procedure GetClientLastError(index: longint; func_error: plongint; socket_error: plongint);
function ClientCount: longint;
function LastCreatedClient: longint;
procedure RecvAck(index: longint);
function BufferContentSize(index: longint): longword;
function BufferPointer(index: longint): pbyte;
procedure Send(index: longint; buf: pbyte; size: longword);
function OutBufferEmpty(index: longint): boolean;
procedure FinishServer(HaltTime: longword);
end;
implementation
constructor TTCPIPServerCommThread.Create(args: PTCPIPServerCommArgs);
begin
inherited Create(false);
FreeOnTerminate := False;
Self.Priority := tpLowest;
Self.ts0.tv_sec := 0;
Self.ts0.tv_nsec := 50000000;
Self.ListenSocket := args^.socket_to_listen;
Self.c_client_index := args^.client_index;
Self.CLIENT_BUFFER_SIZE := args^.bufsize;
Self.c_BufferContentSize := 0;
Self.c_client_received_callback := args^.client_received_callback;
Self.c_client_error_callback := args^.client_error_callback;
Self.c_client_closed_callback := args^.client_closed_callback;
Self.c_client_sent_callback := args^.client_sent_callback;
Self.ClientAddrSize := sizeof(Self.ClientAddr);
Self.FDS := Default(TFDSet);
Self.ERROR_FUNC_CODE := 0;
Self.SOCKET_ERROR_CODE := 0;
Self.ClientSocket := fpaccept(Self.ListenSocket, @(Self.ClientAddr), @(Self.ClientAddrSize));
if (ClientSocket < 0) then
begin
Self.ERROR_FUNC_CODE := FUNC_CODE_ACCEPT;
Self.SOCKET_ERROR_CODE := SocketError;
Self.Terminate;
exit;
end;
Self.Buffer := GetMem(Self.CLIENT_BUFFER_SIZE);
end;
procedure TTCPIPServerCommThread.Execute;
var RD_Count, WT_Count: longint;
begin
while (not Self.Terminated) do
begin
if (Self.c_BufferContentSize = 0) then
begin
fpFD_Zero(Self.FDS);
fpFD_Set(Self.ClientSocket, Self.FDS);
fpSelect(Self.ClientSocket + 1, @(Self.FDS), nil, nil, 5000); // HERE BE BUGS...
if ((not Self.Terminated) and (fpFD_ISSET(Self.ClientSocket, Self.FDS) <> 0)) then
begin
RD_Count := fprecv(Self.ClientSocket, @(Self.Buffer[0]), Self.CLIENT_BUFFER_SIZE, 0);
if (RD_Count < 0) then
begin
Self.ERROR_FUNC_CODE := FUNC_CODE_RECV;
Self.SOCKET_ERROR_CODE := SocketError;
if (Self.c_client_error_callback <> nil) then
begin
Self.c_client_error_callback(@(Self));
end;
end
else
begin
if (RD_Count > 0) then
begin
Self.c_BufferContentSize := RD_Count;
if (Self.c_client_received_callback <> nil) then
begin
Self.c_client_received_callback(@(Self));
end;
end
else
begin
Self.Terminate;
end;
end;
end;
end;
if (Self.OutBufSize > 0) then
begin
WT_Count := fpSend(Self.ClientSocket, Self.OutBuf, Self.OutBufSize, 0);
if (WT_Count < 0) then
begin
Self.ERROR_FUNC_CODE := FUNC_CODE_SEND;
Self.SOCKET_ERROR_CODE := SocketError;
if (Self.c_client_error_callback <> nil) then
begin
Self.c_client_error_callback(@(Self));
end;
end
else
begin
Self.OutBufSize := Self.OutBufSize - WT_Count;
Self.OutBuf := Self.OutBuf + WT_Count;
if (Self.OutBufSize = 0) then
begin
if (Self.c_client_sent_callback <> nil) then
begin
Self.c_client_sent_callback(@(Self));
end;
end;
end;
end;
if ((Self.c_BufferContentSize > 0) and (Self.OutBufSize = 0)) then
begin
fpnanosleep(@(Self.ts0), @(Self.ts1));
end;
end;
CloseSocket(Self.ClientSocket);
if (Self.c_client_closed_callback <> nil) then
begin
Self.c_client_closed_callback(@(Self));
end;
end;
function TTCPIPServerCommThread.ClientIndex: LongInt;
begin
Result := Self.c_client_index;
end;
procedure TTCPIPServerCommThread.GetLastError(func_error: plongint; socket_error: plongint);
begin
func_error^ := Self.ERROR_FUNC_CODE;
socket_error^ := Self.SOCKET_ERROR_CODE;
end;
procedure TTCPIPServerCommThread.FreeBuffer;
begin
FreeMem(Self.Buffer);
end;
procedure TTCPIPServerCommThread.RecvAck;
begin
Self.c_BufferContentSize := 0;
end;
function TTCPIPServerCommThread.BufferContentSize: longword;
begin
Result := Self.c_BufferContentSize;
end;
function TTCPIPServerCommThread.BufferPointer: pbyte;
begin
Result := Self.Buffer;
end;
procedure TTCPIPServerCommThread.Send(buf: pbyte; size: longword);
begin
Self.OutBuf := buf;
Self.OutBufSize := size;
end;
function TTCPIPServerCommThread.OutBufferEmpty: boolean;
begin
Result := Self.OutBufSize = 0;
end;
procedure TTCPIPServerCommThread.FinishClient(HaltTime: longword);
var count: longword;
begin
if (Self.Finished or Self.Terminated) then
begin
exit;
end;
count := (HaltTime div 50) + 1;
Self.Terminate;
while ((not Self.Finished) and (count > 0)) do
begin
fpnanosleep(@(Self.ts0), @(Self.ts1));
dec(count);
end;
Self.FreeBuffer;
end;
constructor TTCPIPServerThread.Create(args: PTCPIPServerArgs);
begin
inherited Create(false);
FreeOnTerminate := False;
Self.Priority := tpLowest;
Self.ts0.tv_sec := 0;
Self.ts0.tv_nsec := 50000000;
Self.client_count := 0;
setlength(Self.clients, Self.client_count);
Self.srv_port := args^.port;
Self.srv_backlog := args^.backlog;
Self.CLIENT_BUFFER_SIZE := args^.bufsize;
Self.srv_client_created_callback := args^.client_created_callback;
Self.srv_client_received_callback := args^.client_received_callback;
Self.srv_client_error_callback := args^.client_error_callback;
Self.srv_client_closed_callback := args^.client_closed_callback;
Self.srv_client_sent_callback := args^.client_sent_callback;
Self.ServerAddr.sin_family := AF_INET;
Self.ServerAddr.sin_addr.s_addr := INADDR_ANY;
Self.ServerAddr.sin_port := htons(Self.srv_port);
Self.FDS := Default(TFDSet);
Self.ERROR_FUNC_CODE := 0;
Self.SOCKET_ERROR_CODE := 0;
Self.ListenSocket := fpSocket (AF_INET, SOCK_STREAM, 0);
if (Self.ListenSocket < 0) then
begin
Self.ERROR_FUNC_CODE := FUNC_CODE_SOCKET;
Self.SOCKET_ERROR_CODE := SocketError;
Self.Terminate;
exit;
end;
fpSetSockOpt(Self.ListenSocket, SOL_SOCKET, SO_REUSEADDR, PChar('True'), Length('True'));
if (fpBind(Self.ListenSocket, @(Self.ServerAddr), sizeof(Self.ServerAddr)) < 0) then
begin
Self.ERROR_FUNC_CODE := FUNC_CODE_BIND;
Self.SOCKET_ERROR_CODE := SocketError;
Self.Terminate;
exit;
end;
if (fpListen(Self.ListenSocket, Self.srv_backlog + 1) < 0) then
begin
Self.ERROR_FUNC_CODE := FUNC_CODE_LISTEN;
Self.SOCKET_ERROR_CODE := SocketError;
Self.Terminate;
exit;
end;
thrargs.socket_to_listen := Self.ListenSocket;
thrargs.bufsize := Self.CLIENT_BUFFER_SIZE;
thrargs.client_received_callback := Self.srv_client_received_callback;
thrargs.client_error_callback := Self.srv_client_error_callback;
thrargs.client_closed_callback := Self.srv_client_closed_callback;
thrargs.client_sent_callback := Self.srv_client_sent_callback;
end;
procedure TTCPIPServerThread.Execute;
const ref: array[0..3] of char = ('N', '/', 'A', #0);
var
i: integer;
f: boolean;
fe, se: longint;
ClientAddr: TInetSockAddr;
ClientAddrSize: LongInt;
ClientSocket: Longint;
begin
ClientAddrSize := SizeOf(ClientAddr);
while (not Self.Terminated) do
begin
fpFD_Zero(Self.FDS);
fpFD_Set(Self.ListenSocket, Self.FDS);
fpSelect(Self.ListenSocket + 1, @(Self.FDS), nil, nil, 5000);
if ((not Self.Terminated) and (fpFD_ISSET(Self.ListenSocket, Self.FDS) <> 0)) then
begin
f := false;
for i := 0 to Self.client_count - 1 do
begin
if (Self.clients[i].Finished) then
begin
f := true;
break;
end;
end;
if (f) then
begin
Self.clients[i].Free;
end
else
begin
f := Self.client_count < Self.srv_backlog;
if (f) then
begin
i := Self.client_count;
inc(Self.client_count);
setlength(Self.clients, Self.client_count);
end;
end;
if (f) then
begin
Self.last_client := i;
thrargs.client_index := Self.last_client;
Self.clients[Self.last_client] := TTCPIPServerCommThread.Create(@thrargs);
Self.GetClientLastError(Self.last_client, @fe, @se);
if ((Self.srv_client_created_callback <> nil) and (fe = 0)) then
begin
Self.srv_client_created_callback(@(Self.clients[Self.last_client]));
end;
end
else
begin
ClientSocket := fpaccept(Self.ListenSocket, @ClientAddr, @ClientAddrSize);
if (ClientSocket >= 0) then
begin
fpSend(ClientSocket, @ref[0], 4, 0);
CloseSocket(ClientSocket);
end;
end;
end;
end;
CloseSocket(Self.ListenSocket);
end;
procedure TTCPIPServerThread.GetLastError(func_error: plongint; socket_error: plongint);
begin
func_error^ := Self.ERROR_FUNC_CODE;
socket_error^ := Self.SOCKET_ERROR_CODE;
end;
procedure TTCPIPServerThread.GetClientLastError(index: longint; func_error: plongint; socket_error: plongint);
begin
if (index < Self.client_count) then
begin
Self.clients[index].GetLastError(func_error, socket_error);
end;
end;
function TTCPIPServerThread.ClientCount: longint;
begin
Result := Self.client_count;
end;
function TTCPIPServerThread.LastCreatedClient: longint;
begin
Result := Self.last_client;
end;
procedure TTCPIPServerThread.RecvAck(index: longint);
begin
if (index < Self.client_count) then
begin
Self.clients[index].RecvAck;
end;
end;
function TTCPIPServerThread.BufferContentSize(index: longint): longword;
begin
if (index < Self.client_count) then
begin
Result := Self.clients[index].BufferContentSize;
end;
end;
function TTCPIPServerThread.BufferPointer(index: longint): pbyte;
begin
if (index < Self.client_count) then
begin
Result := Self.clients[index].Buffer;
end;
end;
procedure TTCPIPServerThread.Send(index: longint; buf: pbyte; size: longword);
begin
if (index < Self.client_count) then
begin
Self.clients[index].OutBuf := buf;
Self.clients[index].OutBufSize := size;
end;
end;
function TTCPIPServerThread.OutBufferEmpty(index: longint): boolean;
begin
if (index < Self.client_count) then
begin
Result := Self.clients[index].OutBufSize = 0;
end;
end;
procedure TTCPIPServerThread.FinishServer(HaltTime: longword);
var
count: longword;
i: integer;
begin
if (Self.Finished or Self.Terminated) then
begin
exit;
end;
for i := 0 to Self.client_count - 1 do
begin
Self.clients[i].FinishClient(HaltTime);
end;
setlength(Self.clients, 0);
count := (HaltTime div 50) + 1;
Self.Terminate;
while ((not Self.Finished) and (count > 0)) do
begin
fpnanosleep(@(Self.ts0), @(Self.ts1));
dec(count);
end;
end;
end.
Recent
