david
e4d0fcb01d
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@46 b6239004-a887-0f4b-9937-50029ccdca16
569 lines
18 KiB
ObjectPascal
569 lines
18 KiB
ObjectPascal
unit uROSynapseSuperTCPServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Indy Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up, Kylix 2 and up }
|
|
{ platform: Win32, Linux }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the RemObjects SDK }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
{$I RemObjects.inc}
|
|
|
|
interface
|
|
uses
|
|
SysUtils, Classes, uROClasses, uROClient, uROClientIntf, uROServerIntf,
|
|
uROSessions, blcksock, uROServer{$IFDEF MSWINDOWS}, Windows{$ENDIF}, uROSynapseSCHelpers,
|
|
uROThreadPool, uROEventRepository, uROSynapseServerSocket;
|
|
|
|
type
|
|
TROSynapseSCServerWorker = class;
|
|
TROSynapseConnectionEvent = procedure (aChannel: IROTransport; const aGuid: TGuid) of object;
|
|
TROSynapseCustomSuperTcpServer = class(TROServer)
|
|
private
|
|
fIndyServer: TROSynapseServerSocket;
|
|
fActive: Boolean;
|
|
fPort: Integer;
|
|
fAckWaitTimeout: Integer;
|
|
fMaxPackageSize: Integer;
|
|
fGuidToClientMap: TStringList;
|
|
fClients: TThreadList;
|
|
fOwnsThreadPool: Boolean;
|
|
fThreadPool: TROThreadPool;
|
|
fSkipAck: Boolean;
|
|
fEventRepository: TROEventRepository;
|
|
fBlockingEvents: Boolean;
|
|
fOnClientConnected: TROSynapseConnectionEvent;
|
|
fOnClientDisconnected: TROSynapseConnectionEvent;
|
|
fAutoRegisterSession: Boolean;
|
|
procedure IntExecute(Sender: TObject; aSock: TTCPBlockSocket);
|
|
procedure SetPort(const Value: Integer);
|
|
procedure SetThreadPool(const Value: TROThreadPool);
|
|
protected
|
|
function IntGetActive: Boolean; override;
|
|
procedure IntSetActive(const Value: Boolean); override;
|
|
|
|
procedure Loaded; override;
|
|
procedure HasData(Id: Integer; aClient: TROSynapseSCServerWorker; aData: TStream);
|
|
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
procedure DispatchEvent(anEventDataItem : TROEventData; aSessionReference : TGUID; aSender: TObject);
|
|
public
|
|
constructor Create(aOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
property Port: Integer read fPort write SetPort default 8095;
|
|
property AckWaitTimeout: Integer read fAckWaitTimeout write fAckWaitTimeout default 10000;
|
|
property MaxPackageSize: Integer read fMaxPackageSize write fMaxPackageSize default 10*1024*1024;
|
|
property SkipAck: Boolean read fSkipAck write fSkipAck default false;
|
|
|
|
property Server: TROSynapseServerSocket read fIndyServer;
|
|
property ThreadPool: TROThreadPool read fThreadPool write SetThreadPool;
|
|
property EventRepository: TROEventRepository read fEventRepository write fEventRepository;
|
|
property BlockingEvents: Boolean read fBlockingEvents write fBlockingEvents default False;
|
|
property OnClientConnected: TROSynapseConnectionEvent read fOnClientConnected write fOnClientConnected;
|
|
property OnClientDisconnected: TROSynapseConnectionEvent read fOnClientDisconnected write fOnClientDisconnected;
|
|
property AutoRegisterSession: Boolean read fAutoRegisterSession write fAutoRegisterSession default true;
|
|
end;
|
|
|
|
TROSynapseSuperTCPServer = class(TROSynapseCustomSuperTcpServer)
|
|
published
|
|
property Port;
|
|
property SkipAck;
|
|
property AckWaitTimeout;
|
|
property MaxPackageSize;
|
|
property EventRepository;
|
|
property BlockingEvents;
|
|
property OnClientConnected;
|
|
property OnClientDisconnected;
|
|
property DefaultResponse;
|
|
property AutoRegisterSession;
|
|
end;
|
|
|
|
TROSynapseSCServerWorker = class(TROSynSuperChannelWorker, IUnknown, IROTransport,
|
|
IROTCPTransport, IROActiveEventServer)
|
|
private
|
|
fOwner: TROSynapseCustomSuperTcpServer;
|
|
fEventManager: IROSessionsChangesListener;
|
|
fRefCount: Integer;
|
|
protected
|
|
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
|
|
function _AddRef: Integer; stdcall;
|
|
function _Release: Integer; stdcall;
|
|
function GetClientAddress : string;
|
|
function GetTransportObject : TObject;
|
|
procedure IncomingData(Id: Integer; aData: TStream); override;
|
|
procedure Connected; override;
|
|
procedure Disconnected(var RestartLoop: Boolean); override;
|
|
procedure EventsRegistered(aSender : TObject; aClient: TGUID);
|
|
procedure DispatchEvent(anEventDataItem : TROEventData; aSessionReference : TGUID; aSender: TObject);
|
|
function GetDefaultResponse: string; override;
|
|
public
|
|
constructor Create(aOwner: TROSynapseCustomSuperTcpServer; aConnection: TTCPBlockSocket);
|
|
destructor Destroy; override;
|
|
|
|
property Owner: TROSynapseCustomSuperTcpServer read fOwner;
|
|
end;
|
|
TROSynapseInvokerQueueItem = class(TInterfacedObject, IROThreadPoolCallback)
|
|
private
|
|
fData: TStream;
|
|
fId: Integer;
|
|
fCaller: TROSynapseCustomSuperTcpServer;
|
|
FClient: TROSynapseSCServerWorker;
|
|
public
|
|
constructor Create(aCaller: TROSynapseCustomSuperTcpServer; aClient: TROSynapseSCServerWorker; Id: Integer; aData: TStream);
|
|
procedure Callback(Caller: TROThreadPool; Thread: TThread);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
implementation
|
|
uses
|
|
uROTypes;
|
|
|
|
{ TROSynapseCustomSuperTcpServer }
|
|
|
|
constructor TROSynapseCustomSuperTcpServer.Create(aOwner: TComponent);
|
|
begin
|
|
inherited Create(aOwner);
|
|
fClients := TThreadList.Create;
|
|
fPort := 8095;
|
|
AckWaitTimeout := 10000;
|
|
fMaxPackageSize := 10 * 1024 * 1024;
|
|
fIndyServer := TROSynapseServerSocket.Create;
|
|
fIndyServer.OnNewConnection := IntExecute;
|
|
fGuidToClientMap := TStringList.Create;
|
|
fGuidToClientMap.Sorted := true;
|
|
DefaultResponse := 'ROSC:Invalid connection string';
|
|
fAutoRegisterSession := True;
|
|
end;
|
|
|
|
destructor TROSynapseCustomSuperTcpServer.Destroy;
|
|
begin
|
|
Active := False;
|
|
fGuidToClientMap.Free;
|
|
fIndyServer.Active := False;
|
|
fIndyServer.Free;
|
|
fClients.Free;
|
|
if fOwnsThreadPool then
|
|
fThreadPool.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.HasData(Id: Integer; aClient: TROSynapseSCServerWorker; aData: TStream);
|
|
var
|
|
lItem: IROThreadPoolCallback;
|
|
lOrg: TROSynapseInvokerQueueItem;
|
|
begin
|
|
lOrg := TROSynapseInvokerQueueItem.Create(Self, aClient, Id, aData);
|
|
lItem := lOrg;
|
|
try
|
|
fThreadPool.QueueItem(lItem);
|
|
except
|
|
aClient.SendError(Id, ScCmdNoAck_QueueFull);
|
|
lOrg.fData := nil; // caller will free it on exceptions
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TSynapseSendEvent = class(TInterfacedObject, IROThreadPoolCallback)
|
|
private
|
|
fStream: TROEventData;
|
|
fOwner: TROSynapseCustomSuperTcpServer;
|
|
fWorkerOverride: IROTransport;
|
|
fClientGuid: TGUID;
|
|
fSender: TROEventRepository;
|
|
protected
|
|
procedure Callback(Caller: TROThreadPool; Thread: TThread);
|
|
public
|
|
constructor Create(aOwner: TROSynapseCustomSuperTcpServer; aClientGuid: TGUID; aSender: TROEventRepository; aData: TROEventData);
|
|
property WorkerOverride: IROTransport read fWorkerOverride write fWorkerOverride;
|
|
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.Notification(AComponent: TComponent; Operation: TOperation);
|
|
begin
|
|
if (Operation = opRemove) then begin
|
|
if AComponent = fThreadPool then
|
|
fThreadPool := nil;
|
|
if AComponent = fEventRepository then
|
|
fEventRepository := nil;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.DispatchEvent(anEventDataItem : TROEventData; aSessionReference : TGUID; aSender: TObject);
|
|
var
|
|
i: Integer;
|
|
aref: IROSessionsChangesListener;
|
|
se: IROThreadPoolCallback;
|
|
begin
|
|
fClients.LockList;
|
|
try
|
|
i := fGuidToClientMap.IndexOf(GUIDToString(aSessionReference));
|
|
if i = -1 then begin
|
|
if fEventRepository <> nil then begin
|
|
if Supports(fEventRepository, IROSessionsChangesListener, aref) then
|
|
aref.SessionsChangedNotification(aSessionReference, saRemoveActiveListener, nil);
|
|
fEventRepository.StoreEventData(EmptyGUID, Binary(anEventDataItem.Data), false, false, GUIDToString(aSessionReference));
|
|
if anEventDataItem.RemoveRef = 0 then anEventDataItem.Free;
|
|
exit;
|
|
end;
|
|
end;
|
|
finally
|
|
fClients.UnlockList;
|
|
end;
|
|
se := TSynapseSendEvent.Create(Self, aSessionReference, TROEventRepository(aSender), anEventDataItem);
|
|
if BlockingEvents then
|
|
se.Callback(fThreadPool, nil)
|
|
else
|
|
fThreadPool.QueueItem(se);
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.IntExecute(sender: TObject; aSock: TTCPBlockSocket);
|
|
var
|
|
fChannel: TROSynapseSCServerWorker;
|
|
begin
|
|
fChannel := TROSynapseSCServerWorker.Create(Self, aSock);
|
|
fChannel.MaxPackageSize:= Self.MaxPackageSize;
|
|
fClients.Add(fChannel);
|
|
try
|
|
fChannel.DoExecute;
|
|
finally
|
|
fClients.Remove(fChannel);
|
|
fChannel.Free;
|
|
end;
|
|
end;
|
|
|
|
function TROSynapseCustomSuperTcpServer.IntGetActive: Boolean;
|
|
begin
|
|
Result := fActive;
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.IntSetActive(const Value: Boolean);
|
|
begin
|
|
fActive := Value;
|
|
if ComponentState * [csDesigning, csLoading] = [] then
|
|
begin
|
|
if fThreadPool = nil then
|
|
begin
|
|
fThreadPool := TROThreadPool.Create(nil);
|
|
fOwnsThreadPool := true;
|
|
end;
|
|
fIndyServer.Active := false;
|
|
if fActive then
|
|
begin
|
|
fIndyServer.Port := fPort;
|
|
fIndyServer.Active := true;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.Loaded;
|
|
begin
|
|
inherited;
|
|
IntSetActive(fActive);
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.SetPort(const Value: Integer);
|
|
begin
|
|
fPort := Value;
|
|
if fActive then
|
|
begin
|
|
IntSetActive(False);
|
|
IntSetActive(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TROSynapseCustomSuperTcpServer.SetThreadPool(const Value: TROThreadPool);
|
|
begin
|
|
if fOwnsThreadPool then
|
|
begin
|
|
fOwnsThreadPool := false;
|
|
fThreadPool.Free;
|
|
end;
|
|
fThreadPool := Value;
|
|
end;
|
|
|
|
|
|
{ TROSynapseSCServerWorker }
|
|
|
|
constructor TROSynapseSCServerWorker.Create(aOwner: TROSynapseCustomSuperTcpServer;
|
|
aConnection: TTCPBlockSocket);
|
|
begin
|
|
fOwner := aOwner;
|
|
inherited Create(aConnection);
|
|
IsServer := true;
|
|
SkipAck := fOwner.Skipack;
|
|
end;
|
|
|
|
destructor TROSynapseSCServerWorker.Destroy;
|
|
begin
|
|
while fRefCount > 0 do
|
|
Sleep(10); // we might have events still waiting.
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TROSynapseSCServerWorker.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
|
|
begin
|
|
if GetInterface(IID, Obj) then
|
|
Result := 0
|
|
else
|
|
Result := E_NOINTERFACE;
|
|
end;
|
|
|
|
function TROSynapseSCServerWorker._AddRef: Integer; stdcall;
|
|
begin
|
|
result := InterlockedIncrement(fRefCount);
|
|
end;
|
|
|
|
function TROSynapseSCServerWorker._Release: Integer; stdcall;
|
|
begin
|
|
result := InterlockedDecrement(fRefCount);
|
|
end;
|
|
|
|
function TROSynapseSCServerWorker.GetClientAddress : string;
|
|
begin
|
|
Result := Connection.GetRemoteSinIP;
|
|
end;
|
|
|
|
function TROSynapseSCServerWorker.GetTransportObject : TObject;
|
|
begin
|
|
Result := Self;
|
|
end;
|
|
|
|
procedure TROSynapseSCServerWorker.IncomingData(Id: Integer; aData: TStream);
|
|
begin
|
|
fOwner.HasData(Id, Self, aData);
|
|
end;
|
|
|
|
procedure TROSynapseSCServerWorker.Connected;
|
|
var
|
|
data, rs: Binary;
|
|
evd: TROEventData;
|
|
i, len: Longint;
|
|
fl: boolean;
|
|
begin
|
|
Len:=0;
|
|
if assigned(fOwner.fOnClientConnected) then fOwner.fOnClientConnected(Self, ClientID);
|
|
fOwner.fClients.LockList;
|
|
try
|
|
i := fOwner.fGuidToClientMap.IndexOf(GUIDToString(ClientId));
|
|
if i = -1 then
|
|
fOwner.fGuidToClientMap.AddObject(GUIDToString(ClientId), Self)
|
|
else
|
|
fOwner.fGuidToClientMap.Objects[i] := Self;
|
|
finally
|
|
fOwner.fClients.UnlockList;
|
|
end;
|
|
if fOwner.fEventRepository <> nil then
|
|
begin
|
|
if fOwner.AutoRegisterSession then begin
|
|
fl := True;
|
|
fOwner.fEventRepository.AddSession(ClientID, Self);
|
|
end
|
|
else begin
|
|
fl := fOwner.fEventRepository.AddActiveListener(ClientID, Self);
|
|
end;
|
|
if fl then begin
|
|
rs := Binary.Create;
|
|
try
|
|
fOwner.fEventRepository.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, fOwner.fEventRepository);
|
|
finally
|
|
data.Free;
|
|
end;
|
|
end;
|
|
finally
|
|
rs.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROSynapseSCServerWorker.Disconnected(var RestartLoop: Boolean);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if fEventManager <> nil then
|
|
fEventManager.SessionsChangedNotification(ClientID, saRemoveActiveListener, Self);
|
|
if RestartLoop then fOwner.fClients.LockList else // for preventing warnings in FPC
|
|
fOwner.fClients.LockList;
|
|
try
|
|
i := fOwner.fGuidToClientMap.IndexOf(GUIDToString(ClientId));
|
|
if i <> -1 then
|
|
begin
|
|
if fOwner.fGuidToClientMap.Objects[i] = self then
|
|
fOwner.fGuidToClientMap.Delete(i);
|
|
end;
|
|
finally
|
|
fOwner.fClients.UnlockList;
|
|
end;
|
|
if assigned(fOwner.fOnClientDisconnected) then fOwner.fOnClientDisconnected(Self, ClientID);
|
|
end;
|
|
|
|
procedure TROSynapseSCServerWorker.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;
|
|
|
|
procedure TROSynapseSCServerWorker.DispatchEvent(anEventDataItem : TROEventData; aSessionReference : TGUID; aSender: TObject);
|
|
var
|
|
se: TSynapseSendEvent;
|
|
begin
|
|
se := TSynapseSendEvent.Create(fOwner, aSessionReference, TROEventRepository(aSender), anEventDataItem);
|
|
se.WorkerOverride := self;
|
|
if fOwner.BlockingEvents then begin
|
|
try
|
|
se.Callback(fOwner.ThreadPool, nil);
|
|
except
|
|
end;
|
|
se.Free;
|
|
end else
|
|
fOwner.ThreadPool.QueueItem(se);
|
|
end;
|
|
|
|
|
|
procedure TSynapseSendEvent.Callback(Caller: TROThreadPool; Thread: TThread);
|
|
var
|
|
ms: TROConstantMemoryStream;
|
|
i: Integer;
|
|
wak: IROSynapsePackageAck;
|
|
ass: IROActiveEventServer;
|
|
obj: TROSynapseSCServerWorker;
|
|
aRef: IROSessionsChangesListener;
|
|
begin
|
|
if (Caller = nil) or (Thread = nil) then obj := nil else // for preventing warnings in FPC
|
|
obj := nil;
|
|
ms := TROConstantMemoryStream.Create(TROConstantMemoryStream(fStream.Data));
|
|
try
|
|
try
|
|
fOwner.fClients.LockList;
|
|
try
|
|
i := fOwner.fGuidToClientMap.IndexOf(GUIDToString(fClientGuid));
|
|
if i = -1 then exit;
|
|
if fWorkerOverride <> nil then
|
|
obj := TROSynapseSCServerWorker(fWorkerOverride.GetTransportObject)
|
|
else
|
|
obj := TROSynapseSCServerWorker(fOwner.fGuidToClientMap.Objects[i]);
|
|
wak := obj.SendPackage(ms, 0);
|
|
if not Supports(obj, IROSessionsChangesListener, ass) then ass := nil;
|
|
finally
|
|
fOwner.fClients.UnlockList;
|
|
end;
|
|
TROSynapseSCServerWorker.WaitForAck(wak, fOwner.fAckWaitTimeout);
|
|
except
|
|
if fOwner.fEventRepository <> nil then begin
|
|
if Supports(fOwner.fEventRepository, IROSessionsChangesListener, aref) then
|
|
aref.SessionsChangedNotification(fClientGuid, saRemoveActiveListener, obj);
|
|
fOwner.fEventRepository.StoreEventData(EmptyGUID, ms, false, false, GUIDToString(fClientGuid));
|
|
exit;
|
|
end;
|
|
end;
|
|
finally
|
|
ms.Free;
|
|
end;
|
|
end;
|
|
|
|
constructor TSynapseSendEvent.Create(aOwner: TROSynapseCustomSuperTcpServer; aClientGuid: TGUID; aSender: TROEventRepository; aData: TROEventData);
|
|
begin
|
|
inherited Create;
|
|
fStream := aData;
|
|
fSender := aSender;
|
|
fClientGuid := aClientGuid;
|
|
fOwner := aOwner;
|
|
end;
|
|
|
|
destructor TSynapseSendEvent.Destroy;
|
|
begin
|
|
if fStream.RemoveRef = 0 then
|
|
fStream.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TROSynapseSCServerWorker.GetDefaultResponse: string;
|
|
begin
|
|
Result:= FOwner.DefaultResponse;
|
|
end;
|
|
|
|
{ TROSynapseInvokerQueueItem }
|
|
|
|
procedure TROSynapseInvokerQueueItem.Callback(Caller: TROThreadPool; Thread: TThread);
|
|
var
|
|
lResponse: TMemoryStream;
|
|
l: TList;
|
|
lClient: IROTransport;
|
|
begin
|
|
if (Thread = nil) or (Caller = nil) then lResponse := TMemoryStream.Create else // for preventing warning in FPC
|
|
lResponse := TMemoryStream.Create;
|
|
try
|
|
lClient := FClient;
|
|
try
|
|
fCaller.DispatchMessage(lClient, fData, lResponse);
|
|
finally
|
|
lClient := nil;
|
|
end;
|
|
lResponse.Seek(0, soFromBeginning);
|
|
l := fCaller.fClients.LockList;
|
|
try
|
|
if l.IndexOf(FClient) = -1 then exit;
|
|
FClient.BeginWriteLock;
|
|
InterlockedIncrement(FClient.fRefCount);
|
|
finally
|
|
fCaller.fClients.UnlockList;
|
|
end;
|
|
try
|
|
if lResponse.Size > FClient.MaxPackageSize then
|
|
FClient.SendError(fId, ScCmdNoAck_MsgTooLarge)
|
|
else
|
|
FClient.SendPackage(lResponse, fId).RemoveFromList; // we're not going to wait
|
|
finally
|
|
InterlockedDecrement(fClient.fRefCount);
|
|
FClient.EndWriteLock;
|
|
end;
|
|
finally
|
|
lResponse.Free;
|
|
end;
|
|
end;
|
|
|
|
constructor TROSynapseInvokerQueueItem.Create(aCaller: TROSynapseCustomSuperTcpServer; aClient: TROSynapseSCServerWorker; Id: Integer; aData: TStream);
|
|
begin
|
|
inherited Create;
|
|
fCaller := aCaller;
|
|
fId := Id;
|
|
fData := aData;
|
|
fClient := aClient;
|
|
end;
|
|
|
|
destructor TROSynapseInvokerQueueItem.Destroy;
|
|
begin
|
|
fData.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
initialization
|
|
RegisterServerClass(TROSynapseSuperTCPServer);
|
|
finalization
|
|
UnregisterServerClass(TROSynapseSuperTCPServer);
|
|
end.
|