 | 
|
|
|
{$INCLUDE ..\cDefines.inc}
unit cTCPServer;
{ }
{ TCP Server Component v3.10 }
{ }
{ This unit is copyright © 2000-2004 by David J Butler }
{ }
{ This unit is part of Delphi Fundamentals. }
{ Its original file name is cTCPServer.pas }
{ The latest version is available from the Fundamentals home page }
{ http://fundementals.sourceforge.net/ }
{ }
{ I invite you to use this unit, free of charge. }
{ I invite you to distibute this unit, but it must be for free. }
{ I also invite you to contribute to its development, }
{ but do not distribute a modified copy of this file. }
{ }
{ A forum is available on SourceForge for general discussion }
{ http://sourceforge.net/forum/forum.php?forum_id=2117 }
{ }
{ }
{ Revision history: }
{ 27/11/2000 0.01 Created cInternetServer unit from cInternetStandards. }
{ 25/01/2001 0.02 Refactored unit. Renamed to cSocketServer. }
{ 25/03/2001 0.03 Removed support for Delphi's sockets. }
{ 15/12/2001 1.04 Server now uses Fundamentals Sockets library. }
{ 11/02/2002 2.05 Refactored for Fundamentals 2. }
{ 16/02/2002 2.06 Added throttling. }
{ 04/09/2002 3.07 Refactored for Fundamentals 3. }
{ Renamed unit to cTCPServer. }
{ 22/06/2003 3.08 Fixed bug in TCPServer.OnDataAvailable. }
{ 16/10/2003 3.09 Fixed bug in threaded mode. }
{ Added InBufferMaxSize and OutBufferMaxSize properties. }
{ 09/04/2004 3.10 Improved client termination. }
{ }
interface
uses
{ Delphi }
Messages,
WinSock,
SysUtils,
Classes,
{ Fundamentals }
cStrings,
cStreams,
cLog,
cThreads,
cSocketsTCP,
cTCPStream,
cSocketsTCPServer;
{ }
{ ATCPServer }
{ Base class for TCP servers. }
{ }
{ PROPERTIES }
{ Active }
{ Set Active = True to enable the server. }
{ }
{ ListenPort }
{ TCP port on which server listens for incoming connections. }
{ }
{ ServerMode }
{ smManualAccept Server triggers an OnConectionAvailable event }
{ and user must call Accept method to accept the }
{ new client. }
{ smAcceptClient Server automatically Accepts new client as }
{ soon as connection is made. }
{ smAcceptClientThread Server automatically Accepts new client as }
{ soon as connection is made. The new client is }
{ created in its own thread. }
{ }
const
WM_TCPSERVER_FREECLIENT = WM_USER + 1281;
type
{ ATCPServer }
TTCPServerClient = class;
CTCPServerClient = class of TTCPServerClient;
ATCPServer = class;
ATCPServerEvent = procedure (Sender: ATCPServer) of object;
ATCPServerLogEvent = procedure (Sender: ATCPServer; Msg : String) of object;
TTCPServerClientEvent = procedure (Sender: TTCPServerClient) of object;
TTCPServerCreateClientEvent = function (Sender: ATCPServer) : TTCPServerClient of object;
TTCPServerClientArray = Array of TTCPServerClient;
TTCPServerMode = (smManualAccept,
smAcceptClient,
smAcceptClientThread);
ATCPServer = class(TComponent)
protected
FOnLog : ATCPServerLogEvent;
FLogTo : TLog;
FServerMode : TTCPServerMode;
FListenPort : String;
FTimeOut : Integer;
FInBufferMaxSize : Integer;
FOutBufferMaxSize : Integer;
FLocalHost : String;
FMaxBacklog : Integer;
FLoadActive : Boolean;
FOnActive : ATCPServerEvent;
FOnInactive : ATCPServerEvent;
FOnConnectionAvailable : ATCPServerEvent;
FOnCreateClient : TTCPServerCreateClientEvent;
FOnClientActive : TTCPServerClientEvent;
FOnClientInactive : TTCPServerClientEvent;
FClientClass : CTCPServerClient;
FOnDataAvailable : TTCPServerClientEvent;
FOnThreadRun : TTCPServerClientEvent;
FMaxClients : Integer;
FOnClientRemoved : TTCPServerClientEvent;
FThrottleClientRead : Boolean;
FThrottleClientReadRate : Integer;
FThrottleClientWrite : Boolean;
FThrottleClientWriteRate : Integer;
FActive : Boolean;
FSocket : TTCPServerSocket;
FClients : TTCPServerClientArray;
FAcceptPending : Boolean;
FStartTime : TDateTime;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Loaded; override;
procedure Init; virtual;
procedure RaiseError(const Msg: String); virtual;
procedure RaiseAndLogError(const Msg: String);
procedure Log(const LogClass: TLogClass; const Msg: String);
procedure SetListenPort(const ListenPort: String);
function GetLocalHost: String;
procedure SetLocalHost(const LocalHost: String);
function GetMaxBacklog: Integer;
procedure SetMaxBacklog(const MaxBacklog: Integer);
procedure SetServerMode(const ServerMode: TTCPServerMode);
procedure SetClientSocketProperties;
procedure SetThrottleClientRead(const ThrottleClientRead: Boolean);
procedure SetThrottleClientWrite(const ThrottleClientWrite: Boolean);
procedure SetThrottleClientReadRate(const ThrottleClientReadRate: Integer);
procedure SetThrottleClientWriteRate(const ThrottleClientWriteRate: Integer);
procedure TriggerActive; virtual;
procedure TriggerInactive; virtual;
procedure Start; virtual;
procedure Stop; virtual;
procedure SetActive(const Active: Boolean);
function GetUpTime: TDateTime;
function GetUpTimeStr: String;
procedure RemoveClientByIndex(const Idx: Integer);
procedure RemoveClient(const Client: TTCPServerClient);
procedure TriggerClientRemoved(const Client: TTCPServerClient);
procedure TriggerClientActive(const Client: TTCPServerClient); virtual;
procedure TriggerClientInactive(const Client: TTCPServerClient); virtual;
procedure TerminateClients;
procedure TriggerConnectionAvailable; virtual;
procedure OnServerConnectionAvailable(Sender: TTCPServerSocket);
procedure AcceptClient;
procedure AcceptClientThread;
function CreateClient: TTCPServerClient; virtual;
procedure TriggerThreadRun(const Client: TTCPServerClient); virtual;
function GetClientCount: Integer;
function GetClientByIndex(const Idx: Integer): TTCPServerClient;
procedure OnClientSocketDataAvailable(Sender: ATCPClientSocket);
procedure OnClientSocketClose(Sender: ATCPClientSocket);
function OnServerMessage(const Msg: Cardinal; const wParam, lParam: Integer;
var Handled: Boolean): Integer;
property OnCreateClient: TTCPServerCreateClientEvent read FOnCreateClient write FOnCreateClient;
property OnClientActive: TTCPServerClientEvent read FOnClientActive write FOnClientActive;
property OnClientInactive: TTCPServerClientEvent read FOnClientInactive write FOnClientInactive;
property OnClientRemoved: TTCPServerClientEvent read FOnClientRemoved write FOnClientRemoved;
property OnDataAvailable: TTCPServerClientEvent read FOnDataAvailable write FOnDataAvailable;
property OnThreadRun: TTCPServerClientEvent read FOnThreadRun write FOnThreadRun;
public
constructor Create(AOwner: TComponent); override;
constructor CreateEx(const ListenPort: String; const TimeOut: Integer;
const ServerMode: TTCPServerMode; const ClientClass: CTCPServerClient);
destructor Destroy; override;
property LogTo: TLog read FLogTo write FLogTo;
property OnLog: ATCPServerLogEvent read FOnLog write FOnLog;
property ServerMode: TTCPServerMode read FServerMode write SetServerMode default smAcceptClient;
function LocalHostName: String;
property LocalHost: String read GetLocalHost write SetLocalHost;
property ListenPort: String read FListenPort write SetListenPort;
property MaxBacklog: Integer read GetMaxBacklog write SetMaxBacklog default DefaultBacklog;
property TimeOut: Integer read FTimeOut write FTimeOut default DefaultSocketStreamTimeOut;
property InBufferMaxSize: Integer read FInBufferMaxSize write FInBufferMaxSize default -1;
property OutBufferMaxSize: Integer read FOutBufferMaxSize write FOutBufferMaxSize default -1;
property MaxClients: Integer read FMaxClients write FMaxClients default -1;
property Active: Boolean read FActive write SetActive default False;
property OnActive: ATCPServerEvent read FOnActive write FOnActive;
property OnInactive: ATCPServerEvent read FOnInactive write FOnInactive;
property StartTime: TDateTime read FStartTime;
property UpTime: TDateTime read GetUpTime;
property UpTimeStr: String read GetUpTimeStr;
property ThrottleClientRead: Boolean read FThrottleClientRead write SetThrottleClientRead default False;
property ThrottleClientReadRate: Integer read FThrottleClientReadRate write SetThrottleClientReadRate default 0;
property ThrottleClientWrite: Boolean read FThrottleClientWrite write SetThrottleClientWrite default False;
property ThrottleClientWriteRate: Integer read FThrottleClientWriteRate write SetThrottleClientWriteRate default 0;
function GetReadRate: Integer;
function GetWriteRate: Integer;
function GetTransferRate: Integer;
function Accept: TTCPServerClient;
property OnConnectionAvailable: ATCPServerEvent read FOnConnectionAvailable write FOnConnectionAvailable;
property Socket: TTCPServerSocket read FSocket;
property Client[const Idx: Integer]: TTCPServerClient read GetClientByIndex;
property ClientCount: Integer read GetClientCount;
function GetClientIndex(const Client: TTCPServerClient): Integer;
function GetClientIndexByStream(const Stream: AStream): Integer;
function GetClientIndexBySocket(const Socket: ATCPClientSocket): Integer;
function HasClient(const Client: TTCPServerClient): Boolean;
end;
ETCPServer = class(Exception);
{ TTCPServerClient }
TTCPServerClientSocket = class(ATCPClientSocket);
TTCPServerClient = class
protected
FWinSocket : TSocket;
FAddress : TSockAddr;
FServer : ATCPServer;
FStream : TSocketStream;
FSocket : TTCPServerClientSocket;
FTerminated : Boolean;
FThread : TThreadEx;
FErrorMsg : String;
FData : Pointer;
procedure Init; virtual;
procedure Log(const LogClass: TLogClass; const Msg: String); virtual;
procedure SetSocketProperties; virtual;
function GetStream: TSocketStream;
procedure ThreadRun; virtual;
procedure ClientError(const Msg: String); virtual;
procedure ClientActive; virtual;
procedure ClientInactive; virtual;
function GetRemoteAddress: TInAddr;
function GetRemoteAddressStr: String;
function GetRemotePort: Integer;
public
constructor Create(const Server: ATCPServer); virtual;
destructor Destroy; override;
property Server: ATCPServer read FServer;
property Socket: TTCPServerClientSocket read FSocket;
function GetSocket: TTCPServerClientSocket;
property Stream: TSocketStream read GetStream;
property Thread: TThreadEx read FThread;
property ErrorMsg: String read FErrorMsg;
property RemoteAddress: TInAddr read GetRemoteAddress;
property RemoteAddressStr: String read GetRemoteAddressStr;
property RemotePort: Integer read GetRemotePort;
property Data: Pointer read FData write FData; // user-defined data
procedure Terminate; virtual;
property Terminated: Boolean read FTerminated;
function ReadAvailable: String;
function PeekStr(const Count: Integer): String;
procedure WriteStr(const S: String);
function ReadEx(const MinCount, MaxCount: Integer; const Delimiter: String;
var Buf: String; const Peek: Boolean = False): Boolean;
function StreamReadLine(var S: String): Boolean;
function SocketReadLine(var Buf: String; const Delimiter: String = CRLF): Boolean;
procedure Synchronize(const Method: TThreadMethod);
end;
{ }
{ TfndTCPServer }
{ }
type
TfndTCPServer = class(ATCPServer)
published
property LogTo;
property OnLog;
property ServerMode;
property LocalHost;
property ListenPort;
property MaxBacklog;
property TimeOut;
property MaxClients;
property ThrottleClientRead;
property ThrottleClientReadRate;
property ThrottleClientWrite;
property ThrottleClientWriteRate;
property OnConnectionAvailable;
property OnDataAvailable;
property OnCreateClient;
property OnClientRemoved;
property OnClientActive;
property OnClientInactive;
property OnThreadRun;
property Active;
property OnActive;
property OnInactive;
end;
implementation
uses
{ Delphi }
Windows,
{ Fundamentals }
cUtils,
cDateTime,
cWinSock;
{ }
{ TTCPServerClientThread }
{ }
type
TTCPServerClientThread = class(TThreadEx)
protected
FServer : ATCPServer;
FClient : TTCPServerClient;
FRunning : Boolean;
FLogClass : TLogClass;
FLogMsg : String;
procedure NotifyLog;
procedure NotifyClientActive;
procedure NotifyClientInactive;
procedure Log(const LogClass: TLogClass; const Msg: String);
procedure Execute; override;
public
constructor Create(const Server: ATCPServer; const Client: TTCPServerClient);
destructor Destroy; override;
procedure Terminate; override;
end;
constructor TTCPServerClientThread.Create(const Server: ATCPServer;
const Client: TTCPServerClient);
begin
Assert(Assigned(Server));
Assert(Assigned(Client));
FServer := Server;
FClient := Client;
FClient.FSocket := nil;
FClient.FThread := self;
FRunning := True;
FreeOnTerminate := False;
inherited Create(False);
end;
destructor TTCPServerClientThread.Destroy;
begin
if FRunning then
Terminate;
if Assigned(FClient) and (FClient.FThread = self) then
FClient.FThread := nil;
inherited Destroy;
end;
procedure TTCPServerClientThread.NotifyClientActive;
begin
if not Assigned(FClient) then
exit;
if Terminated or FClient.Terminated then
exit;
FServer.TriggerClientActive(FClient);
end;
procedure TTCPServerClientThread.NotifyClientInactive;
begin
if not Assigned(FClient) then
exit;
if Terminated or FClient.Terminated then
exit;
FServer.TriggerClientInactive(FClient);
end;
procedure TTCPServerClientThread.NotifyLog;
begin
if not Assigned(FClient) then
exit;
if Terminated or FClient.Terminated then
exit;
FServer.Log(FLogClass, FLogMsg);
end;
procedure TTCPServerClientThread.Log(const LogClass: TLogClass; const Msg: String);
begin
if not Assigned(FClient) then
exit;
if Terminated or FClient.Terminated then
exit;
FLogClass := LogClass;
FLogMsg := Msg;
Synchronize(NotifyLog);
end;
procedure TTCPServerClientThread.Execute;
var Quit : Boolean;
begin
try
Quit := Terminated or not Assigned(FClient) or FClient.Terminated;
if Quit then
exit;
// Socket window must be created in thread to have messages posted to
// this thread.
try
FClient.FStream := TSocketStream.Create(FClient.GetSocket, False,
smBlockWaitMessage, FServer.FTimeOut, FServer.FOutBufferMaxSize);
except
on E: Exception do
begin
Log(lcError, 'Socket creation error: ' + E.Message);
exit;
end;
end;
Quit := Terminated or not Assigned(FClient) or FClient.Terminated or
FClient.FSocket.Terminated;
if Quit then
exit;
// Notify Active
try
FClient.ClientActive;
if Assigned(FServer.FOnClientActive) then
Synchronize(NotifyClientActive);
except
on E: Exception do
begin
Log(lcError, 'Client activate error: ' + E.Message);
exit;
end;
end;
Quit := Terminated or not Assigned(FClient) or FClient.Terminated or
FClient.FSocket.Terminated;
if Quit then
exit;
// Run
try
FClient.ThreadRun;
except
on E: Exception do
begin
Log(lcError, 'Client execute error: ' + E.Message);
exit;
end;
end;
finally
// Notify Inactive
Quit := Terminated or not Assigned(FClient) or FClient.Terminated or
FClient.FSocket.Terminated;
if not Quit then
try
FClient.ClientInactive;
if Assigned(FServer.FOnClientInactive) then
Synchronize(NotifyClientInactive);
except
on E: Exception do
Log(lcError, 'Client deactivate error: ' + E.Message);
end;
if Assigned(FClient) then
PostMessage(FServer.FSocket.WindowHandle, WM_TCPSERVER_FREECLIENT,
Integer(Pointer(FClient)), 0);
FRunning := False;
end;
end;
procedure TTCPServerClientThread.Terminate;
var S : ATCPClientSocket;
begin
if Terminated then
exit;
inherited Terminate;
if Assigned(FClient) then
begin
S := FClient.FSocket;
if Assigned(S) then
begin
S.Terminate;
if S.WindowHandle <> 0 then
PostMessage(S.WindowHandle, WM_QUIT, 0, 0);
end;
end;
end;
function GetTCPServerClientThread(
const Server: ATCPServer;
const Client: TTCPServerClient): TTCPServerClientThread;
begin
Result := TTCPServerClientThread.Create(Server, Client);
end;
{ }
{ ATCPServer }
{ }
constructor ATCPServer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Init;
end;
constructor ATCPServer.CreateEx(const ListenPort: String; const TimeOut: Integer;
const ServerMode: TTCPServerMode; const ClientClass: CTCPServerClient);
begin
inherited Create(nil);
Init;
FTimeOut := TimeOut;
FServerMode := ServerMode;
FClientClass := ClientClass;
FListenPort := ListenPort;
end;
destructor ATCPServer.Destroy;
begin
if not (csDesigning in ComponentState) then
begin
FActive := False;
if Assigned(FSocket) then
FSocket.Close;
FreeAndNilObjectArray(ObjectArray(FClients));
FreeAndNil(FSocket);
end;
inherited Destroy;
end;
procedure ATCPServer.Init;
begin
FTimeOut := DefaultSocketStreamTimeOut;
FServerMode := smAcceptClient;
FMaxClients := -1;
FInBufferMaxSize := -1;
FOutBufferMaxSize := -1;
FMaxBacklog := DefaultBacklog;
if csDesigning in ComponentState then
exit;
FSocket := TTCPServerSocket.Create;
FSocket.OnConnectionAvailable := OnServerConnectionAvailable;
FSocket.OnMessage := OnServerMessage;
end;
procedure ATCPServer.RaiseError(const Msg: String);
begin
raise ETCPServer.Create(Msg);
end;
procedure ATCPServer.RaiseAndLogError(const Msg: String);
begin
Log(lcError, Msg);
RaiseError(Msg);
end;
procedure ATCPServer.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
if AComponent = FLogTo then
FLogTo := nil;
end;
procedure ATCPServer.Loaded;
begin
inherited Loaded;
if csDesigning in ComponentState then
exit;
if FLoadActive then
SetActive(True);
end;
procedure ATCPServer.Log(const LogClass: TLogClass; const Msg: String);
begin
if csDesigning in ComponentState then
exit;
if Assigned(FOnLog) then
FOnLog(self, Msg);
if Assigned(FLogTo) then
FLogTo.Log(self, LogClass, Msg);
end;
procedure ATCPServer.SetListenPort(const ListenPort: String);
begin
if ListenPort = FListenPort then
exit;
if ListenPort = '' then
RaiseError('Invalid ListenPort');
if not (csDesigning in ComponentState) and Active then
RaiseError('Cannot change port while server is active');
FListenPort := ListenPort;
end;
function ATCPServer.GetLocalHost: String;
begin
if csDesigning in ComponentState then
Result := FLocalHost
else
Result := FSocket.LocalHost;
end;
procedure ATCPServer.SetLocalHost(const LocalHost: String);
begin
if LocalHost = FLocalHost then
exit;
if not (csDesigning in ComponentState) and Active then
RaiseError('Cannot change local host while server is active');
FLocalHost := LocalHost;
end;
function ATCPServer.LocalHostName: String;
begin
Result := FSocket.LocalHostName;
end;
function ATCPServer.GetMaxBacklog: Integer;
begin
if csDesigning in ComponentState then
Result := FMaxBacklog
else
Result := FSocket.MaxBacklog;
end;
procedure ATCPServer.SetMaxBacklog(const MaxBacklog: Integer);
begin
if MaxBacklog = FMaxBacklog then
exit;
FMaxBacklog := MaxBacklog;
if csDesigning in ComponentState then
exit;
FSocket.MaxBacklog := MaxBacklog;
end;
procedure ATCPServer.SetServerMode(const ServerMode: TTCPServerMode);
begin
if FServerMode = ServerMode then
exit;
if not (csDesigning in ComponentState) and Active then
RaiseError('Cannot change server mode while server is active');
FServerMode := ServerMode;
end;
procedure ATCPServer.SetClientSocketProperties;
var I : Integer;
begin
FThrottleClientReadRate := ThrottleClientReadRate;
For I := 0 to Length(FClients) - 1 do
FClients[I].SetSocketProperties;
end;
procedure ATCPServer.SetThrottleClientReadRate(const ThrottleClientReadRate: Integer);
begin
if ThrottleClientReadRate = FThrottleClientReadRate then
exit;
FThrottleClientReadRate := ThrottleClientReadRate;
SetClientSocketProperties;
end;
procedure ATCPServer.SetThrottleClientWriteRate(const ThrottleClientWriteRate: Integer);
begin
if ThrottleClientWriteRate = FThrottleClientWriteRate then
exit;
FThrottleClientWriteRate := ThrottleClientWriteRate;
SetClientSocketProperties;
end;
procedure ATCPServer.SetThrottleClientRead(const ThrottleClientRead: Boolean);
begin
if ThrottleClientRead = FThrottleClientRead then
exit;
FThrottleClientRead := ThrottleClientRead;
SetClientSocketProperties;
end;
procedure ATCPServer.SetThrottleClientWrite(const ThrottleClientWrite: Boolean);
begin
if ThrottleClientWrite = FThrottleClientWrite then
exit;
FThrottleClientWrite := ThrottleClientWrite;
SetClientSocketProperties;
end;
procedure ATCPServer.SetActive(const Active: Boolean);
begin
if FActive = Active then
exit;
if csDesigning in ComponentState then
begin
FActive := Active;
exit;
end;
if csLoading in ComponentState then
begin
FLoadActive := Active;
exit;
end;
if Active then
begin
if ListenPort = '' then
RaiseError('ListenPort not set');
try
Start;
except
on E: Exception do
RaiseAndLogError('Server activation failed: ' + E.Message);
end;
FStartTime := Now;
FActive := True;
Log(lcInfo, 'Server active. Listening on port ' + FListenPort + '.');
TriggerActive;
end else
begin
FActive := False;
try
Stop;
except
on E: Exception do
Log(lcError, 'Server deactivation failed: ' + E.Message);
end;
Log(lcInfo, 'Server shutdown.');
TriggerInactive;
end;
end;
function ATCPServer.GetUpTime: TDateTime;
begin
if FActive then
Result := Now - FStartTime
else
Result := 0.0;
end;
function ATCPServer.GetUpTimeStr: String;
begin
Result := DateTimeAsElapsedTime(GetUpTime);
end;
procedure ATCPServer.TriggerActive;
begin
if Assigned(FOnActive) then
FOnActive(self);
end;
procedure ATCPServer.TriggerInactive;
begin
if Assigned(FOnInactive) then
FOnInactive(self);
end;
procedure ATCPServer.Start;
begin
Assert(Assigned(FSocket));
FSocket.LocalHost := FLocalHost;
FSocket.ListenPort := FListenPort;
FSocket.Listen;
end;
procedure ATCPServer.Stop;
begin
Assert(Assigned(FSocket));
FSocket.Close;
TerminateClients;
FreeAndNilObjectArray(ObjectArray(FClients));
end;
procedure ATCPServer.TerminateClients;
var I : Integer;
C : TTCPServerClient;
begin
For I := Length(FClients) - 1 downto 0 do
begin
C := FClients[I];
if not C.Terminated then
C.Terminate;
end;
end;
procedure ATCPServer.OnServerConnectionAvailable(Sender: TTCPServerSocket);
begin
if not FActive then
exit;
if (FMaxClients >= 0) and (ClientCount >= FMaxClients) then
begin
FAcceptPending := True;
exit;
end;
TriggerConnectionAvailable;
if FServerMode = smManualAccept then
exit;
Case FServerMode of
smAcceptClient : AcceptClient;
smAcceptClientThread : AcceptClientThread;
end;
end;
procedure ATCPServer.TriggerConnectionAvailable;
begin
if Assigned(FOnConnectionAvailable) then
FOnConnectionAvailable(self);
end;
function ATCPServer.Accept: TTCPServerClient;
var Socket : TSocket;
Address : TSockAddr;
begin
try
Socket := FSocket.SocketAccept(Address);
except
Result := nil;
exit;
end;
if Socket = INVALID_SOCKET then
begin
Result := nil;
exit;
end;
try
Result := CreateClient;
if not Assigned(Result) then
raise ETCPServer.Create('No client');
except
on E: Exception do
begin
cWinSock.CloseSocket(Socket);
Log(lcError, 'Error creating client: ' + E.Message);
Result := nil;
exit;
end;
end;
Result.FWinSocket := Socket;
Result.FAddress := Address;
Append(ObjectArray(FClients), Result);
end;
procedure ATCPServer.AcceptClient;
var Client : TTCPServerClient;
begin
Repeat
Client := Accept;
if not Assigned(Client) then
exit;
Client.FStream := TSocketStream.Create(Client.GetSocket, False,
smAsynchronous, FTimeOut, FOutBufferMaxSize);
With Client.FSocket do
begin
OnDataAvailable := OnClientSocketDataAvailable;
OnClose := OnClientSocketClose;
end;
TriggerClientActive(Client);
if not FActive or ((FMaxClients >= 0) and (ClientCount >= FMaxClients)) then
exit;
Until False;
end;
procedure ATCPServer.AcceptClientThread;
var Client : TTCPServerClient;
Thread : TTCPServerClientThread;
begin
Repeat
Client := Accept;
if not Assigned(Client) then
exit;
Thread := GetTCPServerClientThread(self, Client);
if not Assigned(Thread) then
begin
Client.Free;
exit;
end;
if not FActive or ((FMaxClients >= 0) and (ClientCount >= FMaxClients)) then
exit;
Until False;
end;
function ATCPServer.CreateClient: TTCPServerClient;
begin
if Assigned(FOnCreateClient) then
begin
Result := FOnCreateClient(self);
if Assigned(Result) then
exit;
end;
if Assigned(FClientClass) then
begin
Result := FClientClass.Create(self);
exit;
end;
Result := TTCPServerClient.Create(self);
end;
procedure ATCPServer.TriggerClientRemoved(const Client: TTCPServerClient);
begin
if Assigned(FOnClientRemoved) then
FOnClientRemoved(Client);
end;
procedure ATCPServer.TriggerClientActive(const Client: TTCPServerClient);
begin
if Assigned(FOnClientActive) then
FOnClientActive(Client);
end;
procedure ATCPServer.TriggerClientInactive(const Client: TTCPServerClient);
begin
if Assigned(FOnClientInactive) then
FOnClientInactive(Client);
end;
procedure ATCPServer.TriggerThreadRun(const Client: TTCPServerClient);
begin
if Assigned(FOnThreadRun) then
FOnThreadRun(Client);
end;
procedure ATCPServer.RemoveClientByIndex(const Idx: Integer);
var Client : TTCPServerClient;
begin
Assert(Idx >= 0);
Client := FClients[Idx];
Remove(ObjectArray(FClients), Idx, 1, False);
TriggerClientRemoved(Client);
if FAcceptPending then
OnServerConnectionAvailable(FSocket);
end;
procedure ATCPServer.RemoveClient(const Client: TTCPServerClient);
var I : Integer;
begin
For I := 0 to Length(FClients) - 1 do
if FClients[I] = Client then
begin
RemoveClientByIndex(I);
exit;
end;
end;
function ATCPServer.GetReadRate: Integer;
var I : Integer;
S : ATCPClientSocket;
begin
Result := 0;
For I := 0 to Length(FClients) - 1 do
begin
S := FClients[I].FSocket;
if Assigned(S) then
Inc(Result, S.GetReadRate);
end;
end;
function ATCPServer.GetWriteRate: Integer;
var I : Integer;
S : ATCPClientSocket;
begin
Result := 0;
For I := 0 to Length(FClients) - 1 do
begin
S := FClients[I].FSocket;
if Assigned(S) then
Inc(Result, S.GetWriteRate);
end;
end;
function ATCPServer.GetTransferRate: Integer;
var I : Integer;
S : ATCPClientSocket;
begin
Result := 0;
For I := 0 to Length(FClients) - 1 do
begin
S := FClients[I].FSocket;
if Assigned(S) then
Inc(Result, S.GetTransferRate);
end;
end;
procedure ATCPServer.OnClientSocketDataAvailable(Sender: ATCPClientSocket);
var I : Integer;
C : TTCPServerClient;
begin
if not FActive or not Assigned(FOnDataAvailable) then
exit;
I := GetClientIndexBySocket(Sender);
if I = -1 then
exit;
C := FClients[I];
if not C.Terminated then
FOnDataAvailable(C);
end;
procedure ATCPServer.OnClientSocketClose(Sender: ATCPClientSocket);
var I : Integer;
C : TTCPServerClient;
begin
I := GetClientIndexBySocket(Sender);
if I < 0 then
exit;
C := FClients[I];
if FActive and not C.Terminated then
TriggerClientInactive(C);
PostMessage(FSocket.WindowHandle, WM_TCPSERVER_FREECLIENT, Integer(Pointer(C)), 0);
end;
function ATCPServer.OnServerMessage(const Msg: Cardinal; const wParam, lParam: Integer;
var Handled: Boolean): Integer;
var C : TTCPServerClient;
I : Integer;
begin
if Msg = WM_TCPSERVER_FREECLIENT then
begin
Handled := True;
C := TTCPServerClient(Pointer(wParam));
I := GetClientIndex(C);
if I >= 0 then
try
RemoveClientByIndex(I);
finally
C.Free;
end;
end
else
Handled := False;
Result := 0;
end;
function ATCPServer.GetClientCount: Integer;
begin
Result := Length(FClients);
end;
function ATCPServer.GetClientByIndex(const Idx: Integer): TTCPServerClient;
begin
Result := FClients[Idx];
end;
function ATCPServer.GetClientIndex(const Client: TTCPServerClient): Integer;
var I : Integer;
begin
For I := 0 to Length(FClients) - 1 do
if FClients[I] = Client then
begin
Result := I;
exit;
end;
Result := -1;
end;
function ATCPServer.GetClientIndexByStream(const Stream: AStream): Integer;
var I : Integer;
begin
For I := 0 to Length(FClients) - 1 do
if Assigned(FClients[I]) and (FClients[I].FStream = Stream) then
begin
Result := I;
exit;
end;
Result := -1;
end;
function ATCPServer.GetClientIndexBySocket(const Socket: ATCPClientSocket): Integer;
var I : Integer;
begin
For I := 0 to Length(FClients) - 1 do
if FClients[I].FSocket = Socket then
begin
Result := I;
exit;
end;
Result := -1;
end;
function ATCPServer.HasClient(const Client: TTCPServerClient): Boolean;
begin
Result := GetClientIndex(Client) >= 0;
end;
{ }
{ TTCPServerClient }
{ }
constructor TTCPServerClient.Create(const Server: ATCPServer);
begin
inherited Create;
Assert(Assigned(Server));
FServer := Server;
Init;
end;
procedure TTCPServerClient.Init;
begin
end;
destructor TTCPServerClient.Destroy;
begin
FreeAndNil(FThread);
FreeAndNil(FStream);
FreeAndNil(FSocket);
inherited Destroy;
end;
procedure TTCPServerClient.Terminate;
var T : Boolean;
begin
FTerminated := True;
if Assigned(FThread) and not FThread.Terminated then
FThread.Terminate;
if Assigned(FSocket) and not FSocket.Terminated then
begin
FSocket.Terminate;
if Assigned(FThread) and (FSocket.WindowHandle <> 0) then
PostMessage(FSocket.WindowHandle, WM_QUIT, 0, 0);
end;
end;
procedure TTCPServerClient.Log(const LogClass: TLogClass; const Msg: String);
begin
if Assigned(FThread) then
TTCPServerClientThread(FThread).Log(LogClass, Msg)
else
if Assigned(FServer) then
FServer.Log(LogClass, Msg);
end;
procedure TTCPServerClient.ThreadRun;
begin
if not FTerminated and Assigned(FServer) then
FServer.TriggerThreadRun(self);
end;
procedure TTCPServerClient.SetSocketProperties;
begin
With FSocket do
begin
ReadThrottleRate := FServer.FThrottleClientReadRate;
ThrottleRead := FServer.FThrottleClientRead;
WriteThrottleRate := FServer.FThrottleClientWriteRate;
ThrottleWrite := FServer.FThrottleClientWrite;
end;
end;
function TTCPServerClient.GetSocket: TTCPServerClientSocket;
begin
if not Assigned(FSocket) then
begin
FSocket := TTCPServerClientSocket.Create(FWinSocket);
FSocket.InBufferMaxSize := FServer.InBufferMaxSize;
SetSocketProperties;
end;
Result := FSocket;
end;
function TTCPServerClient.GetStream: TSocketStream;
begin
if not Assigned(FStream) then
FStream := TSocketStream.Create(GetSocket, False,
smAsynchronous, FServer.FTimeOut, FServer.FOutBufferMaxSize);
Result := FStream;
end;
procedure TTCPServerClient.ClientActive;
begin
end;
procedure TTCPServerClient.ClientInactive;
begin
end;
procedure TTCPServerClient.ClientError(const Msg: String);
begin
FErrorMsg := Msg;
end;
function TTCPServerClient.GetRemoteAddress: TInAddr;
begin
Result := FAddress.sin_addr;
end;
function TTCPServerClient.GetRemoteAddressStr: String;
begin
Result := IPAddressStr(FAddress.sin_addr);
end;
function TTCPServerClient.GetRemotePort: Integer;
begin
Result := NetPortToPort(FAddress.sin_port);
end;
procedure TTCPServerClient.WriteStr(const S: String);
begin
GetStream.WriteStr(S);
end;
function TTCPServerClient.ReadAvailable: String;
begin
Result := GetStream.Reader.ReadAvailable;
end;
function TTCPServerClient.PeekStr(const Count: Integer): String;
begin
Result := GetStream.Reader.PeekStr(Count);
end;
{ Returns True if at least MinCount bytes if available and either i) Delimiter }
{ occurs (Delimiter <> '') or ii) if MaxCount is available (MaxCount <> -1) or }
{ iii) (Delimiter = '') and (MaxCount = -1) }
function TTCPServerClient.ReadEx(const MinCount, MaxCount: Integer;
const Delimiter: String; var Buf: String; const Peek: Boolean): Boolean;
var I, L : Integer;
InBuf : String;
begin
L := GetSocket.InBufferSize;
if (L = 0) or (L < MinCount) then
begin
Buf := '';
Result := False;
exit;
end;
InBuf := FSocket.PeekStr(L);
if Delimiter <> '' then
begin
I := Pos(Delimiter, InBuf);
if (I > 0) and ((MaxCount = -1) or (I <= MaxCount)) then
if I - 1 >= MinCount then
begin
Buf := CopyLeft(InBuf, I - 1);
if not Peek then
FSocket.Skip(I + Length(Delimiter) - 1);
Result := True;
exit;
end else
begin
Result := False;
Buf := '';
exit;
end;
end
else
if MaxCount = -1 then
begin
Buf := InBuf;
if not Peek then
FSocket.Skip(Length(InBuf));
Result := True;
exit;
end;
if (MaxCount >= 0) and (L >= MaxCount) then
begin
Buf := CopyLeft(InBuf, MaxCount);
if not Peek then
FSocket.Skip(MaxCount);
Result := True;
end
else
begin
Buf := '';
Result := False;
end;
end;
function TTCPServerClient.SocketReadLine(var Buf: String; const Delimiter: String): Boolean;
begin
try
Result := ReadEx(0, -1, Delimiter, Buf);
except
on E: Exception do
begin
Log(lcError, 'Read error: ' + E.Message);
Result := False;
end;
end;
end;
function TTCPServerClient.StreamReadLine(var S: String): Boolean;
begin
S := '';
Result := False;
if FTerminated then
exit;
try
S := GetStream.Reader.ExtractLine;
Result := True;
except
on E: Exception do
Log(lcError, 'Read error: ' + E.Message);
end;
end;
procedure TTCPServerClient.Synchronize(const Method: TThreadMethod);
begin
if Assigned(FThread) then
FThread.Synchronize(Method);
end;
end.