david
2a98435b14
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@68 b6239004-a887-0f4b-9937-50029ccdca16
1661 lines
53 KiB
ObjectPascal
1661 lines
53 KiB
ObjectPascal
unit uROIcsAsyncSuperTcpServer;
|
||
|
||
interface
|
||
{$I RemObjects.inc}
|
||
{.$DEFINE RemObjects_ICS_v6}
|
||
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
{$UNDEF RemObjects_ICS_v5}
|
||
{$ENDIF}
|
||
uses
|
||
Classes, Messages, SySutils, SyncObjs, Contnrs,
|
||
uROAsyncSuperTcpServer, uROAsyncSCHelpers, uROClientIntf, uROServerIntf,
|
||
uROClasses, uROThreadPool, uROSessions
|
||
{$IFDEF RemObjects_ICS_v5}, WSocket, WSocketS {$ENDIF}
|
||
{$IFDEF RemObjects_ICS_v6}, OverbyteICSWSocket, OverbyteICSWSocketS, OverbyteIcsWndControl {$ENDIF}
|
||
;
|
||
const
|
||
// Default number of client message pumps for each server component
|
||
DefaultMinClientMessagePumps = 1;
|
||
|
||
type
|
||
// forward declarations
|
||
TROIcsTCPConnection = class;
|
||
TROAsyncSuperTCPServerSocketClient = class;
|
||
TROCustomIcsAsyncSuperTCPServer = class;
|
||
TROIcsMessagePumpThreadList = class;
|
||
|
||
TROIcsMessagePumpSocketActionKind = (akAdd, akRemove);
|
||
TROIcsMessagePumpSocketActionStatus = (asPending, asSuccess, asError);
|
||
|
||
// A class that contains indication for an action to be performed by a message
|
||
// pump thread on a given socket.
|
||
TROIcsMessagePumpSocketAction = class
|
||
private
|
||
FSocket: TCustomWSocket;
|
||
FActionKind: TROIcsMessagePumpSocketActionKind;
|
||
FStatus: TROIcsMessagePumpSocketActionStatus;
|
||
FErrorMessage: string;
|
||
public
|
||
constructor Create(ASocket: TCustomWSocket; AActionKind: TROIcsMessagePumpSocketActionKind);
|
||
|
||
property Status: TROIcsMessagePumpSocketActionStatus read FStatus write FStatus;
|
||
property ErrorMessage: string read FErrorMessage write FErrorMessage;
|
||
property Socket: TCustomWSocket read FSocket;
|
||
property ActionKind: TROIcsMessagePumpSocketActionKind read FActionKind;
|
||
end;
|
||
|
||
// A thread that reads messages for a given number of sockets
|
||
TROIcsMessagePumpThread = class(TROInitializedThread)
|
||
private
|
||
FSockets: TObjectList;
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
FICSHandleHolder: TIcsWndControl;
|
||
{$ENDIF}
|
||
FOwner: TROIcsMessagePumpThreadList;
|
||
|
||
FPendingActionsSection: TCriticalSection;
|
||
FPendingActions: TObjectList;
|
||
|
||
function GetSocket(Index: Integer): TCustomWSocket;
|
||
function GetSocketCount: Integer;
|
||
property Sockets[Index: Integer]: TCustomWSocket read GetSocket;
|
||
|
||
procedure InternalRemoveSocket(ASocket: TCustomWSocket);
|
||
|
||
procedure LockPendingActions;
|
||
procedure UnlockPendingActions;
|
||
procedure DoMessagePumpException(E: TObject);
|
||
protected
|
||
procedure DoTerminate; override;
|
||
public
|
||
constructor Create(AOwner: TROIcsMessagePumpThreadList);
|
||
destructor Destroy; override;
|
||
|
||
procedure Execute; override;
|
||
|
||
function AddSocket(ASocket: TCustomWSocket; out ErrorMessage: string): Boolean;
|
||
function RemoveSocket(ASocket: TCustomWSocket; out ErrorMessage: string): Boolean;
|
||
property SocketCount: Integer read GetSocketCount;
|
||
end;
|
||
|
||
// A list of message pumps
|
||
TROIcsMessagePumpThreadList = class(TObjectList)
|
||
private
|
||
FMinCount: Integer;
|
||
FMaxClientsPerPump: Integer;
|
||
|
||
function GetItem(Index: Integer): TROIcsMessagePumpThread;
|
||
procedure SetItem(Index: Integer; const Value: TROIcsMessagePumpThread);
|
||
procedure SetMinCount(const Value: Integer);
|
||
procedure SetMaxClientsPerPump(const Value: Integer);
|
||
public
|
||
// Returns the first available pump and attaches the given socket to it.
|
||
function GetMessagePump(ASocket: TCustomWSocket): TROIcsMessagePumpThread;
|
||
|
||
property Items[Index: Integer]: TROIcsMessagePumpThread read GetItem write SetItem; default;
|
||
property MinCount: Integer read FMinCount write SetMinCount;
|
||
property MaxClientsPerPump: Integer read FMaxClientsPerPump write SetMaxClientsPerPump;
|
||
end;
|
||
|
||
// A server socket
|
||
TROWSocketServer = class(TCustomWSocketServer)
|
||
protected
|
||
FDisposed: Boolean;
|
||
|
||
FMessagePumpThread: TROIcsMessagePumpThread;
|
||
FServer: TROCustomIcsAsyncSuperTCPServer;
|
||
|
||
procedure WndProc(var MsgRec: TMessage); override;
|
||
procedure InternalClose(bShut : Boolean; Error : Word); override;
|
||
procedure TriggerClientConnect(Client : TWSocketClient; Error : Word); override;
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
procedure Dispose(Disposing: Boolean); override;
|
||
{$ENDIF}
|
||
public
|
||
constructor Create(AServer: TROCustomIcsAsyncSuperTCPServer); reintroduce;
|
||
destructor Destroy; override;
|
||
procedure Listen; override;
|
||
property ClientCount;
|
||
property Client;
|
||
|
||
property MessagePumpThread: TROIcsMessagePumpThread read FMessagePumpThread write FMessagePumpThread;
|
||
property Server: TROCustomIcsAsyncSuperTCPServer read FServer;
|
||
end;
|
||
|
||
// Server component
|
||
TServerSocketBackgroundException = procedure(Sender: TObject; Socket: TROWSocketServer; E: TObject) of object;
|
||
TClientSocketBackgroundException = procedure(Sender: TObject; Socket: TROAsyncSuperTCPServerSocketClient; E: TObject) of object;
|
||
TServerSocketSessionClosed = procedure (Sender: TObject; Socket: TROWSocketServer; ErrCode: Word) of object;
|
||
TROCustomIcsAsyncSuperTCPServer = class(TROBaseAsyncSuperTCPServer)
|
||
private
|
||
fPort: Integer;
|
||
FServerSocket: TROWSocketServer;
|
||
FWorkers: TObjectList;
|
||
FOnServerSocketSessionClosed: TServerSocketSessionClosed;
|
||
FOnServerSocketBackgroundException: TServerSocketBackgroundException;
|
||
FOnClientSocketBackgroundException: TClientSocketBackgroundException;
|
||
FClientMessagePumps: TROIcsMessagePumpThreadList;
|
||
fAutoRegisterSession: Boolean;
|
||
|
||
procedure SetPort(const Value: Integer);
|
||
procedure ServerSocketClientConnect(Sender: TObject; Client: TWSocketClient; Error: Word);
|
||
procedure ServerSocketClientDisconnect(Sender: TObject; Client: TWSocketClient; Error: Word);
|
||
procedure ServerSocketSessionClosed(Sender: TObject; ErrCode: Word);
|
||
procedure ServerSocketBgException(Sender: TObject; E: Exception; var CanClose: Boolean);
|
||
|
||
procedure DoClientSocketException(Socket: TROAsyncSuperTCPServerSocketClient; E: TObject);
|
||
procedure SetMinClientMessagePumps(const Value: Integer);
|
||
function GetMinClientMessagePumps: Integer;
|
||
function GetMaxClientsPerPump: Integer;
|
||
procedure SetMaxClientsPerPump(const Value: Integer);
|
||
protected
|
||
procedure IntSetActive(const Value: boolean); override;
|
||
function IntGetActive: boolean; override;
|
||
|
||
procedure Connect;
|
||
procedure Disconnect;
|
||
public
|
||
constructor Create(aOwner: TComponent); override;
|
||
destructor Destroy; override;
|
||
|
||
property ServerSocket: TROWSocketServer read FServerSocket;
|
||
|
||
property Port: Integer read fPort write SetPort default 8095;
|
||
property AutoRegisterSession: Boolean read fAutoRegisterSession write fAutoRegisterSession default true;
|
||
property MinClientMessagePumps: Integer read GetMinClientMessagePumps write SetMinClientMessagePumps default DefaultMinClientMessagePumps;
|
||
property MaxClientsPerPump: Integer read GetMaxClientsPerPump write SetMaxClientsPerPump;
|
||
|
||
property OnServerSocketSessionClosed: TServerSocketSessionClosed read FOnServerSocketSessionClosed write FOnServerSocketSessionClosed;
|
||
property OnServerSocketBackgroundException: TServerSocketBackgroundException read FOnServerSocketBackgroundException write FOnServerSocketBackgroundException;
|
||
property OnClientSocketBackgroundException: TClientSocketBackgroundException read FOnClientSocketBackgroundException write FOnClientSocketBackgroundException;
|
||
end;
|
||
|
||
TROIcsAsyncSuperTCPServer = class(TROCustomIcsAsyncSuperTCPServer)
|
||
published
|
||
property Port;
|
||
property DefaultResponse;
|
||
property AutoRegisterSession;
|
||
|
||
property OnServerSocketSessionClosed;
|
||
property OnServerSocketBackgroundException;
|
||
property OnClientSocketBackgroundException;
|
||
end;
|
||
|
||
// Server component worker
|
||
TROIcsAsyncSuperChannelWorker = class(TROAsyncSuperChannelWorker, IROTCPTransport, IROActiveEventServer)
|
||
private
|
||
FServer: TROCustomIcsAsyncSuperTCPServer;
|
||
FClient: TROAsyncSuperTCPServerSocketClient;
|
||
FEventManager: IROSessionsChangesListener;
|
||
protected
|
||
{ IROTCPTransport }
|
||
function GetClientAddress : string;
|
||
|
||
{ IROActiveEventServer }
|
||
procedure EventsRegistered(aSender : TObject; aClient: TGUID);
|
||
procedure DispatchEvent(anEventDataItem : TROEventData; aSessionReference : TGUID; aSender: TObject);
|
||
|
||
// overriden methods
|
||
procedure IncomingData(Id: Integer; aData: TByteArray); override;
|
||
procedure Connected; override;
|
||
procedure Disconnected(var RestartLoop: Boolean); override;
|
||
function GetDefaultResponse: string; override;
|
||
public
|
||
constructor Create(AServer: TROCustomIcsAsyncSuperTCPServer; AClient: TROAsyncSuperTCPServerSocketClient);
|
||
destructor Destroy; override;
|
||
end;
|
||
|
||
// Client socket
|
||
TROAsyncSuperTCPServerSocketClient = class(TWSocketClient)
|
||
private
|
||
FTCPConnection: TROIcsTCPConnection;
|
||
FWorker: TROIcsAsyncSuperChannelWorker;
|
||
|
||
FOnDisconnected: TROAsyncCallback;
|
||
FOnHaveIncompleteData: TROAsyncCallback;
|
||
|
||
FInternalReceiveBuffer: array of Byte;
|
||
FInternalReceivedBytes: Integer;
|
||
|
||
FRequestedReceiveBytes: Integer;
|
||
FReceiveBuffer: Pointer;
|
||
FReceivedBytes: Integer;
|
||
FReceiveCallback: TROAsyncCallback;
|
||
|
||
FSentBytes: Integer;
|
||
FSendCallback: TROAsyncCallback;
|
||
|
||
FError: Boolean;
|
||
FConnectCallback: TROAsyncCallback;
|
||
FDisconnectCallback: TROAsyncCallback;
|
||
|
||
FMessagePumpThread: TROIcsMessagePumpThread;
|
||
|
||
procedure ReceiveBytes;
|
||
function InternalReceive(Buffer : Pointer; BufferSize: Integer): Integer;
|
||
|
||
procedure DoSendCallback;
|
||
procedure DoConnectCallback;
|
||
procedure DoDisconnectCallback;
|
||
procedure DoReceiveCallback;
|
||
procedure DoOnDisconnected;
|
||
procedure DoOnHaveIncompleteData;
|
||
|
||
function GetAbstractTCPConnection: IROAbstractTCPConnection;
|
||
protected
|
||
FDisposed: Boolean;
|
||
|
||
procedure WndProc(var MsgRec: TMessage); override;
|
||
|
||
// overriden from TWSocket
|
||
procedure TriggerDataSent(Error: Word); override;
|
||
procedure TriggerSessionConnectedSpecial(Error : Word); override;
|
||
procedure TriggerSessionConnected(Error: Word); override;
|
||
procedure TriggerError; override;
|
||
function TriggerDataAvailable(Error: Word): Boolean; override;
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
procedure Dispose(Disposing: Boolean); override;
|
||
{$ENDIF}
|
||
|
||
// These ones are event handlers because there is no TriggerXXX for them
|
||
procedure HandleBgException(Sender: TObject; E: Exception; var CanClose: Boolean);
|
||
public
|
||
// overriden from TWSocket
|
||
procedure TriggerSessionClosed(Error: Word); override;
|
||
procedure StartConnection; override;
|
||
|
||
constructor Create(AOwner: TComponent); override;
|
||
destructor Destroy; override;
|
||
|
||
procedure DetachFromThread;
|
||
procedure ClearROIcsTCPConnection;
|
||
|
||
property AbstractTCPConnection: IROAbstractTCPConnection read GetAbstractTCPConnection;
|
||
property Worker: TROIcsAsyncSuperChannelWorker read FWorker write FWorker;
|
||
property MessagePumpThread: TROIcsMessagePumpThread read FMessagePumpThread write FMessagePumpThread;
|
||
|
||
property OnDisconnected: TROAsyncCallback read FOnDisconnected write FOnDisconnected;
|
||
property OnHaveIncompleteData: TROAsyncCallback read FOnHaveIncompleteData write FOnHaveIncompleteData;
|
||
|
||
property ConnectCallback: TROAsyncCallback read FConnectCallback write FConnectCallback;
|
||
property DisconnectCallback: TROAsyncCallback read FDisconnectCallback write FDisconnectCallback;
|
||
|
||
property RequestedReceiveBytes: Integer read FRequestedReceiveBytes write FRequestedReceiveBytes;
|
||
property ReceiveBuffer: Pointer read FReceiveBuffer write FReceiveBuffer;
|
||
property ReceivedBytes: Integer read FReceivedBytes write FReceivedBytes;
|
||
property ReceiveCallback: TROAsyncCallback read FReceiveCallback write FReceiveCallback;
|
||
|
||
property SentBytes: Integer read FSentBytes write FSentBytes;
|
||
property SendCallback: TROAsyncCallback read FSendCallback write FSendCallback;
|
||
end;
|
||
|
||
IROAsyncICSSocket = interface
|
||
['{969B866F-9487-4359-86A7-2B1B098D2D38}']
|
||
function GetSelf: TROIcsTCPConnection;
|
||
end;
|
||
|
||
// Class for interface
|
||
TROIcsTCPConnection = class(TInterfacedObject, IROAbstractTCPConnection, IROAsyncICSSocket)
|
||
private
|
||
FClientSocket: TROAsyncSuperTCPServerSocketClient;
|
||
protected
|
||
{ IROAbstractTCPConnection }
|
||
procedure BeginReceive(aData: Pointer; aSize: Integer; aCallback: TROAsyncCallback);
|
||
procedure BeginSend(aData: Pointer; aSize: Integer; aCallback: TROAsyncCallback);
|
||
|
||
function EndReceive: Integer;
|
||
function EndSend: Integer;
|
||
|
||
procedure BeginDisconnect(aForce: Boolean; aCallback: TROAsyncCallback);
|
||
procedure EndDisconnect;
|
||
|
||
procedure BeginConnect(const aAdress: string; aPort: Integer; aCallback: TROAsyncCallback);
|
||
function EndConnect: Boolean;
|
||
|
||
procedure SetOnDisconnected(aCallback: TROAsyncCallback);
|
||
function GetOnDisconnected: TROAsyncCallback;
|
||
|
||
procedure SetOnHaveIncompleteData(aCallback: TROAsyncCallback);
|
||
function GetOnHaveIncompleteData: TROAsyncCallback;
|
||
|
||
{ IROAsyncICSSocket }
|
||
function GetSelf: TROIcsTCPConnection;
|
||
public
|
||
constructor Create(ClientSocket: TROAsyncSuperTCPServerSocketClient);
|
||
destructor Destroy; override;
|
||
|
||
procedure ClearClientSocket;
|
||
end;
|
||
|
||
// Under rare conditions an exception may occur inside the Execute method of
|
||
// message pumps, outside of any work done by a socket they handle message for.
|
||
// Message pumps deal with multiple objects and as such, it is not possible for
|
||
// them to notify one more than the other.
|
||
// However, it may be useful to be notified of such exceptions, which is the
|
||
// reason why the type and procedure below are defined. Give a handler and you
|
||
// will get notified when such an exception occur.
|
||
//
|
||
// WARNING: The parameter named "E" might be nil if the exception does not
|
||
// inherit from TObject. This would happen for instance if it is a
|
||
// system exception that is not managed by the RTL itself.
|
||
type
|
||
TOnMessagePumpException = procedure(E: TObject; IsServerSocketsMessagePump: Boolean) of object;
|
||
|
||
procedure SetOnMessagePumpException(Value: TOnMessagePumpException);
|
||
|
||
// Use the type and method below to get notified when a message pump is terminated
|
||
type
|
||
TOnMessagePumpTerminated = procedure(IsServerSocketsMessagePump: Boolean) of object;
|
||
|
||
procedure SetOnMessagePumpTerminated(Value: TOnMessagePumpTerminated);
|
||
|
||
// Write log. To be removed when things settle down
|
||
procedure WriteICSLog(const Msg: string; IsServer: Boolean); overload;
|
||
|
||
// Get access to the list of server socket message pumps. Useful to set the
|
||
// properties on it, like MinCount and MaxPerCount
|
||
function ServerSocketsMessagePumps: TROIcsMessagePumpThreadList;
|
||
|
||
implementation
|
||
|
||
uses
|
||
{$IFDEF ICS_LOG}
|
||
ServerParameters, ServerLogging, DBObjectsHelpers,
|
||
{$ENDIF ICS_LOG}
|
||
Math, Windows, Winsock, uROEventRepository, uROTypes;
|
||
|
||
const
|
||
InternalReceiveBufferSize = 2048; // Size in bytes of the internal receive buffer, for each client socket
|
||
|
||
var
|
||
FServerSocketsMessagePumps: TROIcsMessagePumpThreadList;
|
||
FOnMessagePumpException: TOnMessagePumpException;
|
||
FOnMessagePumpTerminated: TOnMessagePumpTerminated;
|
||
|
||
procedure SetOnMessagePumpException(Value: TOnMessagePumpException);
|
||
begin
|
||
FOnMessagePumpException := Value;
|
||
end;
|
||
|
||
procedure SetOnMessagePumpTerminated(Value: TOnMessagePumpTerminated);
|
||
begin
|
||
FOnMessagePumpTerminated := Value;
|
||
end;
|
||
|
||
function ServerSocketsMessagePumps: TROIcsMessagePumpThreadList;
|
||
begin
|
||
if not Assigned(FServerSocketsMessagePumps) then
|
||
FServerSocketsMessagePumps := TROIcsMessagePumpThreadList.Create;
|
||
|
||
Result := FServerSocketsMessagePumps;
|
||
end;
|
||
|
||
procedure WriteICSLog(const Msg: string; IsServer: Boolean); overload;
|
||
{$IFDEF ICS_LOG}
|
||
var
|
||
LogFileName: string;
|
||
stream: TFileStream;
|
||
FullMsg: string;
|
||
{$ENDIF ICS_LOG}
|
||
begin
|
||
{$IFDEF ICS_LOG}
|
||
try
|
||
LogFileName := ServerParams.LogFilePath + ServerParams.LogFileBaseName + '_ics_thread_';
|
||
if IsServer then
|
||
LogFileName := LogFileName + 'serveurs'
|
||
else
|
||
LogFileName := LogFileName + 'clients';
|
||
LogFileName := LogFileName + '_' +
|
||
FormatDateTime('yyyymmdd', Now) + '.log';
|
||
|
||
FullMsg := DateTimeToStr(Now) + ' : ' + Msg + #13#10;
|
||
|
||
if not FileExists(LogFileName) then
|
||
stream := TFileStream.Create(LogFileName, fmCreate or fmShareDenyWrite)
|
||
else
|
||
stream := TFileStream.Create(LogFileName, fmOpenReadWrite or fmShareDenyWrite);
|
||
try
|
||
stream.Position := stream.Size;
|
||
stream.Write(PChar(FullMsg)^, Length(FullMsg));
|
||
finally
|
||
stream.Free;
|
||
end;
|
||
except
|
||
// en cas d'exception <20> l'<27>criture, on <20>vite de killer l'appelant
|
||
end;
|
||
{$ENDIF ICS_LOG}
|
||
end;
|
||
|
||
procedure WriteICSLog(const Msg: string; Pump: TROIcsMessagePumpThread); overload;
|
||
begin
|
||
if Assigned(Pump) then
|
||
WriteICSLog(Msg, Pump.FOwner = FServerSocketsMessagePumps)
|
||
else
|
||
WriteICSLog(Msg, False);
|
||
end;
|
||
|
||
{ TROWSocketServer }
|
||
|
||
procedure TROWSocketServer.InternalClose(bShut: Boolean; Error: Word);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
inherited InternalClose(bShut, Error);
|
||
|
||
// to mimick what Indy is doing, we disconnect all clients
|
||
for I := 0 to ClientCount - 1 do
|
||
Client[I].CloseDelayed;
|
||
end;
|
||
|
||
procedure TROWSocketServer.Listen;
|
||
begin
|
||
inherited Listen;
|
||
end;
|
||
|
||
procedure TROWSocketServer.TriggerClientConnect(Client: TWSocketClient;
|
||
Error: Word);
|
||
var
|
||
optval: Integer;
|
||
iStatus: Integer;
|
||
begin
|
||
WriteICSLog(' TROWSocketServer.TriggerClientConnect: Entering...', True);
|
||
Client.ComponentOptions := Client.ComponentOptions + ComponentOptions;
|
||
|
||
if wsoTCPNoDelay in Client.ComponentOptions then
|
||
begin
|
||
optval := -1; { true, 0=false }
|
||
iStatus := WSocket_setsockopt(Client.HSocket, IPPROTO_TCP, TCP_NODELAY, @optval, SizeOf(optval));
|
||
if iStatus <> 0 then
|
||
begin
|
||
SocketError('setsockopt(IPPROTO_TCP, TCP_NODELAY)');
|
||
WriteICSLog(' Error setting socket option, exiting...', True);
|
||
Exit;
|
||
end;
|
||
end;
|
||
|
||
WriteICSLog(' Calling inherited...', True);
|
||
inherited TriggerClientConnect(Client, Error);
|
||
WriteICSLog(' TROWSocketServer.TriggerClientConnect: Normal end.', True);
|
||
end;
|
||
|
||
constructor TROWSocketServer.Create(AServer: TROCustomIcsAsyncSuperTCPServer);
|
||
begin
|
||
inherited Create(nil);
|
||
|
||
FServer := AServer;
|
||
ComponentOptions := ComponentOptions + [wsoTCPNoDelay];
|
||
end;
|
||
|
||
destructor TROWSocketServer.Destroy;
|
||
begin
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Freeing server socket...');
|
||
{$ENDIF ICS_LOG}
|
||
inherited Destroy;
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Server socket freed.');
|
||
{$ENDIF ICS_LOG}
|
||
end;
|
||
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
procedure TROWSocketServer.Dispose(Disposing: Boolean);
|
||
var
|
||
ErrorMessage: string;
|
||
begin
|
||
if not FDisposed then
|
||
begin
|
||
if Assigned(FMessagePumpThread) then
|
||
FMessagePumpThread.RemoveSocket(Self, ErrorMessage);
|
||
|
||
FDisposed := True;
|
||
end;
|
||
|
||
inherited Dispose(Disposing);
|
||
end;
|
||
{$ENDIF}
|
||
procedure TROWSocketServer.WndProc(var MsgRec: TMessage);
|
||
begin
|
||
WriteICSLog('TROWSocketServer.WndProc: Processing a message...', FMessagePumpThread);
|
||
WriteICSLog(Format(' MsgRec.Msg=$%.4x', [MsgRec.Msg]), FMessagePumpThread);
|
||
WriteICSLog(Format(' MsgRec.wParam=$%.8x - FHSocket=$%.8x', [MsgRec.wParam, FHSocket]), FMessagePumpThread);
|
||
WriteICSLog(Format(' MsgRec.lParamLo=$%.2x', [MsgRec.lParamLo]), FMessagePumpThread);
|
||
WriteICSLog(Format(' FPaused=%s', [BoolToStr(FPaused, True)]), FMessagePumpThread);
|
||
inherited WndProc(MsgRec);
|
||
WriteICSLog('TROWSocketServer.WndProc: Message processed.', FMessagePumpThread);
|
||
end;
|
||
|
||
{ TROCustomIcsAsyncSuperTCPServer }
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.Connect;
|
||
begin
|
||
// Assign properties here as Close clears them
|
||
FServerSocket.Port := IntToStr(fPort);
|
||
FServerSocket.Proto := 'tcp';
|
||
FServerSocket.Addr := '0.0.0.0'; // Listen on any interface
|
||
FServerSocket.Listen;
|
||
end;
|
||
|
||
constructor TROCustomIcsAsyncSuperTCPServer.Create(aOwner: TComponent);
|
||
begin
|
||
inherited Create(aOwner);
|
||
|
||
fPort := 8095;
|
||
|
||
FWorkers := TObjectList.Create;
|
||
FClientMessagePumps := TROIcsMessagePumpThreadList.Create;
|
||
|
||
MinClientMessagePumps := DefaultMinClientMessagePumps;
|
||
|
||
FServerSocket := TROWSocketServer.Create(Self);
|
||
FServerSocket.ClientClass := TROAsyncSuperTCPServerSocketClient;
|
||
FServerSocket.Banner := '';
|
||
FServerSocket.BannerTooBusy := '';
|
||
FServerSocket.OnClientConnect := ServerSocketClientConnect;
|
||
FServerSocket.OnClientDisconnect := ServerSocketClientDisconnect;
|
||
FServerSocket.OnBgException := ServerSocketBgException;
|
||
FServerSocket.OnSessionClosed := ServerSocketSessionClosed;
|
||
DefaultResponse := 'ROSC:Invalid connection string';
|
||
fAutoRegisterSession := True;
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Adding server socket...');
|
||
{$ENDIF ICS_LOG}
|
||
FServerSocket.MessagePumpThread := ServerSocketsMessagePumps.GetMessagePump(FServerSocket);
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Server socket added.');
|
||
{$ENDIF ICS_LOG}
|
||
end;
|
||
|
||
destructor TROCustomIcsAsyncSuperTCPServer.Destroy;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
for i := FWorkers.Count -1 downto 0 do begin
|
||
fWorkers[i] := nil;
|
||
end;
|
||
inherited Destroy;
|
||
|
||
// Done after because the inherited Destroy sets Active to False which
|
||
// tries to disconnect the socket
|
||
FServerSocket.Free;
|
||
FClientMessagePumps.Free;
|
||
FWorkers.Free;
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.Disconnect;
|
||
begin
|
||
FServerSocket.Close;
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.DoClientSocketException(
|
||
Socket: TROAsyncSuperTCPServerSocketClient; E: TObject);
|
||
begin
|
||
if Assigned(FOnClientSocketBackgroundException) then
|
||
OnClientSocketBackgroundException(Self, Socket, E);
|
||
end;
|
||
|
||
function TROCustomIcsAsyncSuperTCPServer.GetMaxClientsPerPump: Integer;
|
||
begin
|
||
Result := FClientMessagePumps.MaxClientsPerPump;
|
||
end;
|
||
|
||
function TROCustomIcsAsyncSuperTCPServer.GetMinClientMessagePumps: Integer;
|
||
begin
|
||
Result := FClientMessagePumps.MinCount;
|
||
end;
|
||
|
||
function TROCustomIcsAsyncSuperTCPServer.IntGetActive: boolean;
|
||
begin
|
||
Result := Assigned(FServerSocket) and not (FServerSocket.State in [wsClosed, wsInvalidState]);
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.IntSetActive(const Value: boolean);
|
||
begin
|
||
if Value <> Active then
|
||
begin
|
||
if fThreadPool = nil then begin
|
||
fThreadPool := TROThreadPool.Create(nil);
|
||
fOwnsThreadpool := true;
|
||
end;
|
||
|
||
if Value then
|
||
Connect
|
||
else
|
||
Disconnect;
|
||
end;
|
||
end;
|
||
|
||
// This handler is called when a listening (server) socket experienced a
|
||
// background exception. Should normally never occur.
|
||
procedure TROCustomIcsAsyncSuperTCPServer.ServerSocketBgException(
|
||
Sender: TObject; E: Exception; var CanClose: Boolean);
|
||
begin
|
||
CanClose := False; // Let's hope server can still continue
|
||
if Assigned(FOnServerSocketBackgroundException) then
|
||
OnServerSocketBackgroundException(Self, Sender as TROWSocketServer, E);
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.ServerSocketClientConnect(
|
||
Sender: TObject; Client: TWSocketClient; Error: Word);
|
||
var
|
||
Worker: TROIcsAsyncSuperChannelWorker;
|
||
begin
|
||
Worker := TROIcsAsyncSuperChannelWorker.Create(Self, Client as TROAsyncSuperTCPServerSocketClient);
|
||
Worker.DoSetup;
|
||
|
||
FWorkers.Add(Worker);
|
||
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Adding client socket...');
|
||
{$ENDIF ICS_LOG}
|
||
// Only attach here and not in "ClientCreate" so that if the socket cannot
|
||
// be attached, it can at least be closed.
|
||
TROAsyncSuperTCPServerSocketClient(Client).MessagePumpThread := FClientMessagePumps.GetMessagePump(Client); //GetClientSocketMessagePump(Client);
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Client socket added.');
|
||
{$ENDIF ICS_LOG}
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.ServerSocketClientDisconnect(
|
||
Sender: TObject; Client: TWSocketClient; Error: Word);
|
||
begin
|
||
// Wait for client to be actually disconnected before removing the worker
|
||
while Client.State <> wsClosed do
|
||
SleepEx(5, True);
|
||
|
||
FWorkers.Remove((Client as TROAsyncSuperTCPServerSocketClient).Worker);
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.ServerSocketSessionClosed(
|
||
Sender: TObject; ErrCode: Word);
|
||
begin
|
||
if Assigned(OnServerSocketSessionClosed) then
|
||
OnServerSocketSessionClosed(Self, Sender as TROWSocketServer, ErrCode);
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.SetMaxClientsPerPump(
|
||
const Value: Integer);
|
||
begin
|
||
FClientMessagePumps.MaxClientsPerPump := Value;
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.SetMinClientMessagePumps(
|
||
const Value: Integer);
|
||
begin
|
||
FClientMessagePumps.MinCount := Value;
|
||
end;
|
||
|
||
procedure TROCustomIcsAsyncSuperTCPServer.SetPort(const Value: Integer);
|
||
begin
|
||
if fPort <> Value then
|
||
begin
|
||
fPort := Value;
|
||
FServerSocket.Port := IntToStr(fPort);
|
||
end;
|
||
end;
|
||
|
||
{ TROAsyncSuperTCPServerSocketClient }
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.ClearROIcsTCPConnection;
|
||
begin
|
||
FTCPConnection := nil;
|
||
end;
|
||
|
||
constructor TROAsyncSuperTCPServerSocketClient.Create(AOwner: TComponent);
|
||
begin
|
||
try
|
||
inherited Create(AOwner);
|
||
|
||
// No receive loop so that when the "TriggerDataAvailable" code could not
|
||
// read all the data available, the message pump is not stopped and any other
|
||
// client socket associated to it continues to work.
|
||
ComponentOptions := ComponentOptions + [wsoNoReceiveLoop, wsoTCPNoDelay];
|
||
|
||
SetLength(FInternalReceiveBuffer, InternalReceiveBufferSize);
|
||
OnBgException := HandleBgException;
|
||
except
|
||
on E: TObject do
|
||
begin
|
||
FState := wsClosed;
|
||
raise;
|
||
end
|
||
else
|
||
begin
|
||
FState := wsClosed;
|
||
raise;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
destructor TROAsyncSuperTCPServerSocketClient.Destroy;
|
||
begin
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Freeing client socket...');
|
||
{$ENDIF ICS_LOG}
|
||
inherited Destroy;
|
||
|
||
// Done after because the inherited Destroy might want to do some network cleanup
|
||
if Assigned(FTCPConnection) then
|
||
FTCPConnection.ClearClientSocket;
|
||
|
||
SetLength(FInternalReceiveBuffer, 0);
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Client freed...');
|
||
{$ENDIF ICS_LOG}
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.DetachFromThread;
|
||
var
|
||
ErrorMessage: string;
|
||
begin
|
||
if Assigned(FMessagePumpThread) then
|
||
FMessagePumpThread.RemoveSocket(Self, ErrorMessage);
|
||
end;
|
||
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
procedure TROAsyncSuperTCPServerSocketClient.Dispose(Disposing: Boolean);
|
||
begin
|
||
if not FDisposed then
|
||
begin
|
||
// Done here, just in case it was not done by the Worker instance
|
||
// Note that if it has already been done, it's not a problem as ICS is
|
||
// designed to ignore duplicate requests to detach a socket.
|
||
DetachFromThread;
|
||
|
||
FDisposed := True;
|
||
end;
|
||
|
||
inherited Dispose(Disposing);
|
||
end;
|
||
{$ENDIF}
|
||
procedure TROAsyncSuperTCPServerSocketClient.DoConnectCallback;
|
||
begin
|
||
if Assigned(FConnectCallback) then
|
||
FConnectCallback(AbstractTCPConnection);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.DoDisconnectCallback;
|
||
begin
|
||
if Assigned(FDisconnectCallback) then
|
||
FDisconnectCallback(AbstractTCPConnection);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.DoOnDisconnected;
|
||
begin
|
||
if Assigned(FOnDisconnected) then
|
||
FOnDisconnected(AbstractTCPConnection);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.DoOnHaveIncompleteData;
|
||
begin
|
||
if Assigned(FOnHaveIncompleteData) then
|
||
FOnHaveIncompleteData(AbstractTCPConnection);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.DoReceiveCallback;
|
||
begin
|
||
if Assigned(FReceiveCallback) then
|
||
FReceiveCallback(AbstractTCPConnection);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.DoSendCallback;
|
||
begin
|
||
if Assigned(FSendCallback) then
|
||
FSendCallback(AbstractTCPConnection);
|
||
end;
|
||
|
||
function TROAsyncSuperTCPServerSocketClient.GetAbstractTCPConnection: IROAbstractTCPConnection;
|
||
begin
|
||
if not Assigned(FTCPConnection) then
|
||
FTCPConnection := TROIcsTCPConnection.Create(Self);
|
||
|
||
Result := FTCPConnection;
|
||
end;
|
||
|
||
// This event handler is called when a client socket experience a background
|
||
// exception. It is likely to occur when client aborted connection and data
|
||
// has not been sent yet.
|
||
// Warning: This procedure is executed in worker thread context.
|
||
procedure TROAsyncSuperTCPServerSocketClient.HandleBgException(Sender: TObject;
|
||
E: Exception; var CanClose: Boolean);
|
||
begin
|
||
// kill client connection if possible and necessary
|
||
CanClose := not (State in [wsInvalidState, wsClosed]);
|
||
(Server as TROWSocketServer).Server.DoClientSocketException(Self, E);
|
||
end;
|
||
|
||
function TROAsyncSuperTCPServerSocketClient.InternalReceive(Buffer: Pointer;
|
||
BufferSize: Integer): Integer;
|
||
begin
|
||
Result := Min(BufferSize, FInternalReceivedBytes);
|
||
if Result > 0 then
|
||
begin
|
||
// Copy bytes into destination buffer
|
||
CopyMemory(Buffer, FInternalReceiveBuffer, Result);
|
||
|
||
// Shift remaining bytes (if any) in the internal buffer.
|
||
Dec(FInternalReceivedBytes, Result);
|
||
if FInternalReceivedBytes > 0 then
|
||
MoveMemory(FInternalReceiveBuffer, @(FInternalReceiveBuffer[Result]), FInternalReceivedBytes);
|
||
end;
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.ReceiveBytes;
|
||
var
|
||
ReadBytes: Integer;
|
||
begin
|
||
if Assigned(FReceiveBuffer) then
|
||
begin
|
||
repeat
|
||
// Retrieve the bytes from the internal buffer, if any are available
|
||
ReadBytes := InternalReceive(FReceiveBuffer, FRequestedReceiveBytes - FReceivedBytes);
|
||
if ReadBytes >= 0 then
|
||
begin
|
||
Inc(FReceivedBytes, ReadBytes);
|
||
Inc(PByte(FReceiveBuffer), ReadBytes);
|
||
if FReceivedBytes >= FRequestedReceiveBytes then
|
||
begin
|
||
FRequestedReceiveBytes := 0;
|
||
DoReceiveCallback;
|
||
end;
|
||
end;
|
||
|
||
// We are looping here because a client socket might have received more
|
||
// bytes than what the worker class has requested at first, for instance
|
||
// received 6 and 5 were initially requested. Those 5 are read by the
|
||
// call to ReceiveBytes inside the TriggerDataAvailable override, and
|
||
// analysed via the DoReceiveCallback call above. This in turn might
|
||
// trigger the request for more bytes.
|
||
// But if we did not loop here, the available byte would never be read
|
||
// and would stay in the buffer in front of the next bytes received
|
||
// later on. Then the TriggerDataAvailable called at that later time would
|
||
// trigger the request of N bytes and get this extra byte in front of
|
||
// them. This extra byte would then prevent the correct processing of
|
||
// the other bytes.
|
||
until (FInternalReceivedBytes <= 0) or (FRequestedReceiveBytes <= 0);
|
||
end;
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.StartConnection;
|
||
begin
|
||
inherited StartConnection;
|
||
|
||
DoConnectCallback;
|
||
end;
|
||
|
||
function TROAsyncSuperTCPServerSocketClient.TriggerDataAvailable(
|
||
Error: Word): Boolean;
|
||
var
|
||
ReadBytes: Integer;
|
||
begin
|
||
inherited TriggerDataAvailable(Error);
|
||
|
||
// Read the available data into our internal buffer if it can hold more data
|
||
if FInternalReceivedBytes < InternalReceiveBufferSize then
|
||
begin
|
||
ReadBytes := Receive(@(FInternalReceiveBuffer[FInternalReceivedBytes]), InternalReceiveBufferSize - FInternalReceivedBytes);
|
||
if ReadBytes >= 0 then
|
||
Inc(FInternalReceivedBytes, ReadBytes);
|
||
end;
|
||
|
||
// Notify that we have data and immediately try to read it, the callback
|
||
// might have requested it already. Note that this last part has to be done
|
||
// so that the message pump can be left without any knowledge of sockets
|
||
// waiting for data. This allows faster processing and less stress on the
|
||
// data buffer when transferring large chunks of data.
|
||
DoOnHaveIncompleteData;
|
||
ReceiveBytes;
|
||
|
||
// Return True to indicate that we have read the data.
|
||
Result := True;
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.TriggerDataSent(Error: Word);
|
||
begin
|
||
inherited TriggerDataSent(Error);
|
||
|
||
DoSendCallback;
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.TriggerError;
|
||
begin
|
||
inherited TriggerError;
|
||
|
||
FError := True;
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.TriggerSessionClosed(Error: Word);
|
||
begin
|
||
// The inherited call will notify the server socket through messaging. So
|
||
// we do any cleanup before the server is notified as our cleanup must not
|
||
// be disturbed by the server doing its own cleanup.
|
||
DoDisconnectCallback;
|
||
DoOnDisconnected;
|
||
|
||
inherited TriggerSessionClosed(Error);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.TriggerSessionConnected(
|
||
Error: Word);
|
||
begin
|
||
inherited TriggerSessionConnected(Error);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.TriggerSessionConnectedSpecial(
|
||
Error: Word);
|
||
begin
|
||
inherited TriggerSessionConnectedSpecial(Error);
|
||
end;
|
||
|
||
procedure TROAsyncSuperTCPServerSocketClient.WndProc(var MsgRec: TMessage);
|
||
begin
|
||
WriteICSLog('TROAsyncSuperTCPServerSocketClient.WndProc: Processing a message...', FMessagePumpThread);
|
||
WriteICSLog(Format(' MsgRec.Msg=$%.4x', [MsgRec.Msg]), FMessagePumpThread);
|
||
WriteICSLog(Format(' MsgRec.wParam=$%.8x - FHSocket=$%.8x', [MsgRec.wParam, FHSocket]), FMessagePumpThread);
|
||
WriteICSLog(Format(' MsgRec.lParamLo=$%.2x', [MsgRec.lParamLo]), FMessagePumpThread);
|
||
WriteICSLog(Format(' FPaused=%s', [BoolToStr(FPaused, True)]), FMessagePumpThread);
|
||
inherited WndProc(MsgRec);
|
||
WriteICSLog('TROAsyncSuperTCPServerSocketClient.WndProc: Message processed.', FMessagePumpThread);
|
||
end;
|
||
|
||
{ TROIcsAsyncSuperChannelWorker }
|
||
|
||
procedure TROIcsAsyncSuperChannelWorker.Connected;
|
||
var
|
||
data, rs: Binary;
|
||
evd: TROEventData;
|
||
i, len: Longint;
|
||
fl: Boolean;
|
||
begin
|
||
if assigned(FServer.OnClientConnected) then
|
||
FServer.OnClientConnected(Self, ClientID);
|
||
FServer.fClients.LockList;
|
||
try
|
||
i := FServer.GuidToClientMap.IndexOf(GUIDToString(ClientId));
|
||
if i = -1 then
|
||
FServer.GuidToClientMap.AddObject(GUIDToString(ClientId), Self)
|
||
else
|
||
FServer.GuidToClientMap.Objects[i] := Self;
|
||
finally
|
||
FServer.fClients.UnlockList;
|
||
end;
|
||
|
||
if FServer.EventRepository <> nil then
|
||
begin
|
||
if FServer.AutoRegisterSession then begin
|
||
fl := True;
|
||
FServer.EventRepository.AddSession(ClientID, Self);
|
||
end
|
||
else begin
|
||
fl := FServer.EventRepository.AddActiveListener(ClientID, Self);
|
||
end;
|
||
if fl then begin
|
||
rs := Binary.Create;
|
||
try
|
||
FServer.EventRepository.GetEventData(ClientID, rs);
|
||
rs.Position := 0;
|
||
if rs.Read(len, sizeof(len)) <> sizeof(len) then exit;
|
||
while true do begin
|
||
if rs.Read(len, sizeof(len)) <> sizeof(len) then break;
|
||
data := Binary.Create;
|
||
data.CopyFrom(rs, Len);
|
||
data.Position := 0;
|
||
evd := TROEventData.Create(data);
|
||
try
|
||
DispatchEvent(evd, ClientID, FServer.EventRepository);
|
||
finally
|
||
data.Free;
|
||
end;
|
||
end;
|
||
finally
|
||
rs.Free;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
constructor TROIcsAsyncSuperChannelWorker.Create(
|
||
AServer: TROCustomIcsAsyncSuperTCPServer; AClient: TROAsyncSuperTCPServerSocketClient);
|
||
begin
|
||
inherited Create(AClient.AbstractTCPConnection);
|
||
|
||
FServer := AServer;
|
||
FClient := AClient;
|
||
|
||
IsServer := True;
|
||
FServer.FClients.Add(self);
|
||
FClient.Worker := Self;
|
||
end;
|
||
|
||
destructor TROIcsAsyncSuperChannelWorker.Destroy;
|
||
begin
|
||
FServer.FClients.Remove(Self);
|
||
|
||
// Detach from thread here to prevent the thread to call "write" or "read"
|
||
// methods on a destroyed worker.
|
||
FClient.DetachFromThread;
|
||
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TROIcsAsyncSuperChannelWorker.Disconnected(var RestartLoop: Boolean);
|
||
var
|
||
i: Integer;
|
||
begin
|
||
if fEventManager <> nil then
|
||
fEventManager.SessionsChangedNotification(ClientID, saRemoveActiveListener, Self);
|
||
FServer.fClients.LockList;
|
||
try
|
||
i := FServer.GuidToClientMap.IndexOf(GUIDToString(ClientId));
|
||
if i <> -1 then
|
||
begin
|
||
if FServer.GuidToClientMap.Objects[i] = self then
|
||
FServer.GuidToClientMap.Delete(i);
|
||
end;
|
||
finally
|
||
FServer.fClients.UnlockList;
|
||
end;
|
||
if assigned(FServer.OnClientDisconnected) then FServer.OnClientDisconnected(Self, ClientID);
|
||
end;
|
||
|
||
procedure TROIcsAsyncSuperChannelWorker.DispatchEvent(
|
||
anEventDataItem: TROEventData; aSessionReference: TGUID; aSender: TObject);
|
||
var
|
||
se: TSendEvent;
|
||
begin
|
||
se := TSendEvent.Create(FServer, aSessionReference, TROEventRepository(aSender), anEventDataItem);
|
||
se.WorkerOverride := self;
|
||
if FServer.BlockingEvents then
|
||
begin
|
||
try
|
||
se.Callback(FServer.ThreadPool, nil);
|
||
except
|
||
end;
|
||
se.Free;
|
||
end
|
||
else
|
||
begin
|
||
FServer.ThreadPool.QueueItem(se);
|
||
end;
|
||
end;
|
||
|
||
procedure TROIcsAsyncSuperChannelWorker.EventsRegistered(aSender: TObject;
|
||
aClient: TGUID);
|
||
var
|
||
lNew : IROSessionsChangesListener;
|
||
begin
|
||
Supports(aSender, IROSessionsChangesListener, lNew);
|
||
if (fEventManager <> nil) and (lNew <> fEventManager) then
|
||
begin
|
||
fEventManager.SessionsChangedNotification(aClient, saRemoveActiveListener, Self);
|
||
end;
|
||
fEventManager := lNew;
|
||
end;
|
||
|
||
function TROIcsAsyncSuperChannelWorker.GetClientAddress: string;
|
||
begin
|
||
if not (FClient.State in [wsInvalidState, wsConnecting, wsClosed]) then
|
||
Result := FClient.PeerAddr
|
||
else
|
||
Result := '';
|
||
end;
|
||
|
||
function TROIcsAsyncSuperChannelWorker.GetDefaultResponse: string;
|
||
begin
|
||
Result := FServer.DefaultResponse;
|
||
end;
|
||
|
||
procedure TROIcsAsyncSuperChannelWorker.IncomingData(Id: Integer;
|
||
aData: uROAsyncSCHelpers.TByteArray);
|
||
var
|
||
Stream: TMemoryStream;
|
||
begin
|
||
Stream := TMemoryStream.Create;
|
||
try
|
||
Stream.Write(aData[0], Length(aData));
|
||
FServer.HasData(Id, Self, Stream);
|
||
except // only on failure
|
||
Stream.Free;
|
||
raise;
|
||
end;
|
||
end;
|
||
|
||
{ TROIcsMessagePumpSocketAction }
|
||
|
||
constructor TROIcsMessagePumpSocketAction.Create(ASocket: TCustomWSocket;
|
||
AActionKind: TROIcsMessagePumpSocketActionKind);
|
||
begin
|
||
inherited Create;
|
||
|
||
FSocket := ASocket;
|
||
FActionKind := AActionKind;
|
||
FStatus := asPending;
|
||
end;
|
||
|
||
{ TMessagePumpThread }
|
||
|
||
function TROIcsMessagePumpThread.AddSocket(ASocket: TCustomWSocket; out ErrorMessage: string): Boolean;
|
||
var
|
||
Action: TROIcsMessagePumpSocketAction;
|
||
begin
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Adding a socket...');
|
||
{$ENDIF ICS_LOG}
|
||
if not Assigned(ASocket) then
|
||
begin
|
||
Result := False;
|
||
ErrorMessage := 'Attempted to add a nil socket';
|
||
Exit;
|
||
end;
|
||
|
||
// Detach from current thread
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Detaching socket...');
|
||
{$ENDIF ICS_LOG}
|
||
ASocket.ThreadDetach;
|
||
TWSocket(ASocket).MultiThreaded := True;
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Socket detached.');
|
||
{$ENDIF ICS_LOG}
|
||
|
||
// Add action to attach socket to message pump thread
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Adding "add action" for socket to action list...');
|
||
{$ENDIF ICS_LOG}
|
||
Action := TROIcsMessagePumpSocketAction.Create(ASocket, akAdd);
|
||
try
|
||
LockPendingActions;
|
||
try
|
||
FPendingActions.Add(Action);
|
||
finally
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Unlocking pending actions list...');
|
||
{$ENDIF ICS_LOG}
|
||
UnlockPendingActions;
|
||
end;
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Action added to list.');
|
||
{$ENDIF ICS_LOG}
|
||
|
||
// Wait for action to be performed
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Waiting for action to complete...');
|
||
{$ENDIF ICS_LOG}
|
||
while Action.Status = asPending do
|
||
SleepEx(1, True);
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Action has been done.');
|
||
{$ENDIF ICS_LOG}
|
||
|
||
Result := Action.Status = asSuccess;
|
||
ErrorMessage := Action.ErrorMessage;
|
||
finally
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Freeing action.');
|
||
{$ENDIF ICS_LOG}
|
||
Action.Free;
|
||
end;
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Normal end.');
|
||
{$ENDIF ICS_LOG}
|
||
end;
|
||
|
||
constructor TROIcsMessagePumpThread.Create(AOwner: TROIcsMessagePumpThreadLIst);
|
||
begin
|
||
inherited Create(True);
|
||
|
||
FOwner := AOwner;
|
||
FPendingActionsSection := TCriticalSection.Create;
|
||
|
||
FSockets := TObjectList.Create(False);
|
||
FPendingActions := TObjectList.Create(False);
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
FICSHandleHolder := TIcsWndControl.Create(nil);
|
||
{$ENDIF}
|
||
Suspended := False;
|
||
end;
|
||
|
||
destructor TROIcsMessagePumpThread.Destroy;
|
||
begin
|
||
// Force thread to terminate
|
||
Terminate;
|
||
FSockets.Clear;
|
||
|
||
inherited Destroy;
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
FICSHandleHolder.Free;
|
||
{$ENDIF}
|
||
|
||
FSockets.Free;
|
||
FPendingActions.Free;
|
||
|
||
FPendingActionsSection.Free;
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThread.DoMessagePumpException(E: TObject);
|
||
begin
|
||
try
|
||
if Assigned(FOnMessagePumpException) then
|
||
FOnMessagePumpException(E, FOwner = FServerSocketsMessagePumps);
|
||
except
|
||
; // can't accept any exceptions here or it would kill the caller
|
||
end;
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThread.DoTerminate;
|
||
begin
|
||
try
|
||
inherited DoTerminate;
|
||
|
||
if Assigned(FOnMessagePumpTerminated) then
|
||
FOnMessagePumpTerminated(FOwner = FServerSocketsMessagePumps);
|
||
except
|
||
; // can't accept any exception here or it would kill the caller
|
||
end;
|
||
end;
|
||
|
||
type
|
||
TAccessWSocket = class(TCustomWSocket);
|
||
|
||
procedure TROIcsMessagePumpThread.Execute;
|
||
var
|
||
MsgRec: TMsg;
|
||
I: Integer;
|
||
pHandles: Pointer;
|
||
Action: TROIcsMessagePumpSocketAction;
|
||
begin
|
||
WriteICSLog('Start of Execute method.', Self);
|
||
// Process messages until WM_QUIT has been received or Terminated set to True
|
||
repeat
|
||
try
|
||
// Attach handle holder. Done inside the repeat loop so that we do not
|
||
// have to duplicate the try..except handling in case the handle holder
|
||
// cannot be attached.
|
||
// We are using this handle holder so that ICS will create the handle
|
||
// as early as possible and keep using it throughout the life of the
|
||
// process. This way, if later in its life it would not be possible to
|
||
// create new handles, we would have the one created here the first time
|
||
// the loop goes through. Note that this situation (no more handles) is
|
||
// more likely to happen with a very busy process using Indy for most of
|
||
// its tasks as Indy uses a lot of resources.
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
if FICSHandleHolder.Handle = 0 then
|
||
FICSHandleHolder.ThreadAttach;
|
||
{$ENDIF}
|
||
|
||
// Got a message? Process it and do it first in the loop as its processing
|
||
// can trigger code that adds sockets, removes some, requests bytes...
|
||
if PeekMessage(MsgRec, 0, 0, 0, PM_REMOVE) then
|
||
begin
|
||
WriteICSLog(Format('Translating message $%.4x', [MsgRec.message]), Self);
|
||
TranslateMessage(MsgRec);
|
||
WriteICSLog(Format('Dispatching message $%.4x', [MsgRec.message]), Self);
|
||
DispatchMessage(MsgRec);
|
||
WriteICSLog('Message dispatched.', Self);
|
||
end;
|
||
|
||
// If socket actions are waiting, perform them
|
||
if FPendingActions.Count > 0 then
|
||
begin
|
||
WriteICSLog('Processing socket actions...', Self);
|
||
LockPendingActions;
|
||
try
|
||
while FPendingActions.Count > 0 do
|
||
begin
|
||
Action := TROIcsMessagePumpSocketAction(FPendingActions[0]);
|
||
try
|
||
try
|
||
case Action.ActionKind of
|
||
akAdd:
|
||
begin
|
||
WriteICSLog(' Adding a socket...', Self);
|
||
Action.Socket.ThreadAttach;
|
||
FSockets.Add(Action.Socket);
|
||
WriteICSLog(' Socket added.', Self);
|
||
end;
|
||
akRemove:
|
||
begin
|
||
WriteICSLog(' Removing a socket...', Self);
|
||
InternalRemoveSocket(Action.Socket);
|
||
WriteICSLog(' Socket removed.', Self);
|
||
end;
|
||
end;
|
||
Action.Status := asSuccess;
|
||
except
|
||
on E: TObject do
|
||
begin
|
||
Action.Status := asError;
|
||
Action.ErrorMessage := E.ClassName;
|
||
if E is Exception then
|
||
Action.ErrorMessage := Action.ErrorMessage + ', ' + Exception(E).Message;
|
||
raise;
|
||
end;
|
||
else
|
||
begin
|
||
Action.Status := asError;
|
||
Action.ErrorMessage := 'Unknow exception';
|
||
raise;
|
||
end;
|
||
end;
|
||
finally
|
||
FPendingActions.Delete(0);
|
||
end;
|
||
end;
|
||
finally
|
||
WriteICSLog('Unlocking pending socket actions list...', Self);
|
||
UnlockPendingActions;
|
||
end;
|
||
WriteICSLog('New socket actions processed.', Self);
|
||
end;
|
||
|
||
// If there are messages in the queue, then do not wait at all, else, wait
|
||
// as little as possible, so as to avoid 100% CPU usage and still process
|
||
// as fast as we possibly can.
|
||
MsgWaitForMultipleObjectsEx(0, pHandles, 1, QS_ALLINPUT, MWMO_ALERTABLE);
|
||
except
|
||
// Ensure that no exception kills the message processing thread. If we
|
||
// did not do that, the server would still respond to connection attempts
|
||
// but would not reply to any bytes it would receive.
|
||
on E: TObject do
|
||
DoMessagePumpException(E);
|
||
else
|
||
DoMessagePumpException(nil);
|
||
end;
|
||
until Terminated or (MsgRec.message = WM_QUIT);
|
||
|
||
WriteICSLog('Quitting execute method, cleaning up...', Self);
|
||
// Indicate to all sockets that they are terminated
|
||
for I := 0 to FSockets.Count - 1 do
|
||
TAccessWSocket(Sockets[I]).FTerminated := True;
|
||
|
||
// Detach all remaining sockets
|
||
while FSockets.Count > 0 do
|
||
InternalRemoveSocket(Sockets[0]);
|
||
SleepEx(1, True);
|
||
|
||
// Detach handle holder
|
||
{$IFDEF RemObjects_ICS_v6}
|
||
if FICSHandleHolder.Handle <> 0 then
|
||
FICSHandleHolder.ThreadDetach;
|
||
{$ENDIF}
|
||
|
||
WriteICSLog('End of Execute method.', Self);
|
||
end;
|
||
|
||
function TROIcsMessagePumpThread.GetSocket(Index: Integer): TCustomWSocket;
|
||
begin
|
||
Result := FSockets[Index] as TCustomWSocket;
|
||
end;
|
||
|
||
function TROIcsMessagePumpThread.GetSocketCount: Integer;
|
||
begin
|
||
Result := FSockets.Count;
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThread.InternalRemoveSocket(ASocket: TCustomWSocket);
|
||
begin
|
||
if ASocket is TROWSocketServer then
|
||
TROWSocketServer(ASocket).MessagePumpThread := nil;
|
||
if ASocket is TROAsyncSuperTCPServerSocketClient then
|
||
TROAsyncSuperTCPServerSocketClient(ASocket).MessagePumpThread := nil;
|
||
|
||
ASocket.ThreadDetach;
|
||
FSockets.Remove(ASocket);
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThread.LockPendingActions;
|
||
begin
|
||
FPendingActionsSection.Acquire;
|
||
end;
|
||
|
||
function TROIcsMessagePumpThread.RemoveSocket(ASocket: TCustomWSocket; out ErrorMessage: string): Boolean;
|
||
var
|
||
Action: TROIcsMessagePumpSocketAction;
|
||
begin
|
||
// Add action to detach socket from message pump thread
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Adding "remove action" for socket to action list...');
|
||
{$ENDIF ICS_LOG}
|
||
Action := TROIcsMessagePumpSocketAction.Create(ASocket, akRemove);
|
||
try
|
||
LockPendingActions;
|
||
try
|
||
FPendingActions.Add(Action);
|
||
finally
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Unlocking pending actions list...');
|
||
{$ENDIF ICS_LOG}
|
||
UnlockPendingActions;
|
||
end;
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Action added to list.');
|
||
{$ENDIF ICS_LOG}
|
||
|
||
// Wait for action to be performed
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Waiting for action to complete...');
|
||
{$ENDIF ICS_LOG}
|
||
while Action.Status = asPending do
|
||
SleepEx(1, True);
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Action has been done.');
|
||
{$ENDIF ICS_LOG}
|
||
|
||
Result := Action.Status = asSuccess;
|
||
ErrorMessage := Action.ErrorMessage;
|
||
finally
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Freeing action.');
|
||
{$ENDIF ICS_LOG}
|
||
Action.Free;
|
||
end;
|
||
{$IFDEF ICS_LOG}
|
||
WriteLog('[ICS] Normal end.');
|
||
{$ENDIF ICS_LOG}
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThread.UnlockPendingActions;
|
||
begin
|
||
FPendingActionsSection.Release;
|
||
end;
|
||
|
||
{ TROIcsMessagePumpThreadList }
|
||
|
||
function TROIcsMessagePumpThreadList.GetMessagePump(
|
||
ASocket: TCustomWSocket): TROIcsMessagePumpThread;
|
||
var
|
||
ErrorMessage: string;
|
||
MinCount: Integer;
|
||
I: Integer;
|
||
CurCount: Integer;
|
||
LeastCountIndex: Integer;
|
||
begin
|
||
// Let's find the pump that has the least number of sockets
|
||
MinCount := MaxInt;
|
||
LeastCountIndex := -1;
|
||
for I := 0 to Count - 1 do
|
||
begin
|
||
CurCount := Items[I].SocketCount;
|
||
if CurCount < MinCount then
|
||
begin
|
||
MinCount := CurCount;
|
||
LeastCountIndex := I;
|
||
end;
|
||
end;
|
||
|
||
// Two cases:
|
||
// 1. No pump found or found pump is full, create a new one
|
||
// 2. No limit set or pump is not full, use the found pump
|
||
if (LeastCountIndex = -1) or ((MaxClientsPerPump > 0) and (MinCount > MaxClientsPerPump)) then
|
||
Result := Items[Add(TROIcsMessagePumpThread.Create(Self))]
|
||
else
|
||
Result := Items[LeastCountIndex];
|
||
|
||
// Now that we have a pump, attach the socket to it
|
||
if not Result.AddSocket(ASocket, ErrorMessage) then
|
||
ASocket.Close;
|
||
end;
|
||
|
||
function TROIcsMessagePumpThreadList.GetItem(
|
||
Index: Integer): TROIcsMessagePumpThread;
|
||
begin
|
||
Result := TROIcsMessagePumpThread(inherited Items[Index]);
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThreadList.SetItem(Index: Integer;
|
||
const Value: TROIcsMessagePumpThread);
|
||
begin
|
||
inherited Items[Index] := Value;
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThreadList.SetMaxClientsPerPump(
|
||
const Value: Integer);
|
||
var
|
||
ConstrainedValue: Integer;
|
||
begin
|
||
ConstrainedValue := Value;
|
||
if ConstrainedValue < 0 then
|
||
ConstrainedValue := 0;
|
||
|
||
if FMaxClientsPerPump <> ConstrainedValue then
|
||
FMaxClientsPerPump := ConstrainedValue;
|
||
end;
|
||
|
||
procedure TROIcsMessagePumpThreadList.SetMinCount(const Value: Integer);
|
||
var
|
||
ConstrainedValue: Integer;
|
||
I: Integer;
|
||
begin
|
||
ConstrainedValue := Value;
|
||
if ConstrainedValue < 1 then
|
||
ConstrainedValue := 1;
|
||
|
||
if FMinCount <> ConstrainedValue then
|
||
begin
|
||
FMinCount := ConstrainedValue;
|
||
|
||
if Count < MinCount then
|
||
for I := Count to MinCount - 1 do
|
||
Add(TROIcsMessagePumpThread.Create(Self));
|
||
end;
|
||
end;
|
||
|
||
{ TROIcsTCPConnection }
|
||
|
||
procedure TROIcsTCPConnection.BeginConnect(const aAdress: string;
|
||
aPort: Integer; aCallback: TROAsyncCallback);
|
||
begin
|
||
FClientSocket.ConnectCallback := aCallback;
|
||
FClientSocket.Addr := aAdress;
|
||
FClientSocket.Port := IntToStr(aPort);
|
||
FClientSocket.Connect;
|
||
end;
|
||
|
||
procedure TROIcsTCPConnection.BeginDisconnect(aForce: Boolean;
|
||
aCallback: TROAsyncCallback);
|
||
begin
|
||
FClientSocket.DisconnectCallback := aCallback;
|
||
FClientSocket.CloseDelayed;
|
||
end;
|
||
|
||
procedure TROIcsTCPConnection.BeginReceive(aData: Pointer;
|
||
aSize: Integer; aCallback: TROAsyncCallback);
|
||
begin
|
||
FClientSocket.ReceiveCallback := aCallback;
|
||
FClientSocket.RequestedReceiveBytes := aSize;
|
||
FClientSocket.ReceiveBuffer := aData;
|
||
FClientSocket.ReceivedBytes := 0;
|
||
end;
|
||
|
||
procedure TROIcsTCPConnection.BeginSend(aData: Pointer;
|
||
aSize: Integer; aCallback: TROAsyncCallback);
|
||
begin
|
||
FClientSocket.SendCallback := aCallback;
|
||
FClientSocket.Send(aData, aSize);
|
||
FClientSocket.SentBytes := aSize;
|
||
end;
|
||
|
||
procedure TROIcsTCPConnection.ClearClientSocket;
|
||
begin
|
||
FClientSocket := nil;
|
||
end;
|
||
|
||
constructor TROIcsTCPConnection.Create(
|
||
ClientSocket: TROAsyncSuperTCPServerSocketClient);
|
||
begin
|
||
inherited Create;
|
||
|
||
FClientSocket := ClientSocket;
|
||
end;
|
||
|
||
destructor TROIcsTCPConnection.Destroy;
|
||
begin
|
||
if Assigned(FClientSocket) then
|
||
FClientSocket.ClearROIcsTCPConnection;
|
||
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TROIcsTCPConnection.EndConnect: Boolean;
|
||
begin
|
||
FClientSocket.ConnectCallback := nil;
|
||
Result := True;
|
||
end;
|
||
|
||
procedure TROIcsTCPConnection.EndDisconnect;
|
||
begin
|
||
FClientSocket.DisconnectCallback := nil;
|
||
end;
|
||
|
||
function TROIcsTCPConnection.EndReceive: Integer;
|
||
begin
|
||
FClientSocket.ReceiveBuffer := nil;
|
||
FClientSocket.ReceiveCallback := nil;
|
||
Result := FClientSocket.ReceivedBytes;
|
||
end;
|
||
|
||
function TROIcsTCPConnection.EndSend: Integer;
|
||
begin
|
||
FClientSocket.Flush;
|
||
FClientSocket.SendCallback := nil;
|
||
Result := FClientSocket.SentBytes;
|
||
end;
|
||
|
||
function TROIcsTCPConnection.GetOnDisconnected: TROAsyncCallback;
|
||
begin
|
||
if Assigned(FClientSocket) then
|
||
Result := FClientSocket.OnDisconnected;
|
||
end;
|
||
|
||
function TROIcsTCPConnection.GetOnHaveIncompleteData: TROAsyncCallback;
|
||
begin
|
||
if Assigned(FClientSocket) then
|
||
Result := FClientSocket.OnHaveIncompleteData;
|
||
end;
|
||
|
||
function TROIcsTCPConnection.GetSelf: TROIcsTCPConnection;
|
||
begin
|
||
Result := Self;
|
||
end;
|
||
|
||
procedure TROIcsTCPConnection.SetOnDisconnected(aCallback: TROAsyncCallback);
|
||
begin
|
||
if Assigned(FClientSocket) then
|
||
FClientSocket.OnDisconnected := aCallback;
|
||
end;
|
||
|
||
procedure TROIcsTCPConnection.SetOnHaveIncompleteData(
|
||
aCallback: TROAsyncCallback);
|
||
begin
|
||
if Assigned(FClientSocket) then
|
||
FClientSocket.OnHaveIncompleteData := aCallback;
|
||
end;
|
||
|
||
initialization
|
||
FServerSocketsMessagePumps := TROIcsMessagePumpThreadList.Create;
|
||
|
||
finalization
|
||
FServerSocketsMessagePumps.Free;
|
||
|
||
end.
|