david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
549 lines
17 KiB
ObjectPascal
549 lines
17 KiB
ObjectPascal
unit uROSuperTCPServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ 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,
|
|
{$IFDEF REMOBJECTS_TRIAL}uROTrial, {$ENDIF} uROSessions,
|
|
IdTCPConnection, IdTCPServer, uROServer{$IFDEF WIN32}, Windows{$ENDIF}, uROSCHelpers,
|
|
uROThreadPool{$IFDEF RemObjects_INDY10}, IdContext{$ENDIF}, uROEventRepository;
|
|
|
|
type
|
|
TROSCServerWorker = class;
|
|
TROConnectionEvent = procedure (aChannel: IROTransport; const aGuid: TGuid) of object;
|
|
TROCustomSuperTcpServer = class(TROServer)
|
|
private
|
|
fIndyServer: TIdTCPServer;
|
|
fActive: Boolean;
|
|
fPort: Integer;
|
|
fAckWaitTimeout: Integer;
|
|
fMaxPackageSize: Integer;
|
|
fGuidToClientMap: TStringList;
|
|
fClients: TThreadList;
|
|
fOwnsThreadPool: Boolean;
|
|
fThreadPool: TROThreadPool;
|
|
fSkipAck: Boolean;
|
|
fEventRepository: TROEventRepository;
|
|
fBlockingEvents: Boolean;
|
|
fOnClientConnected: TROConnectionEvent;
|
|
fOnClientDisconnected: TROConnectionEvent;
|
|
procedure IntExecute(AThread: {$IFDEF RemObjects_INDY10}TIdContext{$ELSE}TIdPeerThread{$ENDIF});
|
|
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: TROSCServerWorker; 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 1024*1024;
|
|
property SkipAck: Boolean read fSkipAck write fSkipAck default false;
|
|
|
|
property Server: TIdTcpServer 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: TROConnectionEvent read fOnClientConnected write fOnClientConnected;
|
|
property OnClientDisconnected: TROConnectionEvent read fOnClientDisconnected write fOnClientDisconnected;
|
|
end;
|
|
|
|
TROSuperTcpServer = class(TROCustomSuperTcpServer)
|
|
published
|
|
property Port;
|
|
property SkipAck;
|
|
property AckWaitTimeout;
|
|
property MaxPackageSize;
|
|
property EventRepository;
|
|
property BlockingEvents;
|
|
property OnClientConnected;
|
|
property OnClientDisconnected;
|
|
end;
|
|
|
|
TROSCServerWorker = class(TROSuperChannelWorker, IUnknown, IROTransport,
|
|
IROTCPTransport, IROActiveEventServer)
|
|
private
|
|
fOwner: TROCustomSuperTcpServer;
|
|
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);
|
|
public
|
|
constructor Create(aOwner: TROCustomSuperTcpServer; aConnection: TIdTCPConnection);
|
|
destructor Destroy; override;
|
|
|
|
property Owner: TROCustomSuperTcpServer read fOwner;
|
|
end;
|
|
TROInvokerQueueItem = class(TInterfacedObject, IROThreadPoolCallback)
|
|
private
|
|
fData: TStream;
|
|
fId: Integer;
|
|
fCaller: TROCustomSuperTcpServer;
|
|
FClient: TROSCServerWorker;
|
|
public
|
|
constructor Create(aCaller: TROCustomSuperTcpServer; aClient: TROSCServerWorker; Id: Integer; aData: TStream);
|
|
procedure Callback(Caller: TROThreadPool; Thread: TThread);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
implementation
|
|
uses
|
|
uROTypes;
|
|
|
|
{ TROCustomSuperTcpServer }
|
|
|
|
constructor TROCustomSuperTcpServer.Create(aOwner: TComponent);
|
|
begin
|
|
inherited Create(aOwner);
|
|
fClients := TThreadList.Create;
|
|
fPort := 8095;
|
|
AckWaitTimeout := 10000;
|
|
fMaxPackageSize := 1024 * 1024;
|
|
fIndyServer := TIdTCPServer.Create(nil);
|
|
fIndyServer.OnExecute := IntExecute;
|
|
fGuidToClientMap := TStringList.Create;
|
|
fGuidToClientMap.Sorted := true;
|
|
|
|
end;
|
|
|
|
destructor TROCustomSuperTcpServer.Destroy;
|
|
begin
|
|
Active := False;
|
|
fGuidToClientMap.Free;
|
|
fIndyServer.Active := False;
|
|
fIndyServer.Free;
|
|
fClients.Free;
|
|
if fOwnsThreadPool then
|
|
fThreadPool.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TROCustomSuperTcpServer.HasData(Id: Integer; aClient: TROSCServerWorker; aData: TStream);
|
|
var
|
|
lItem: IROThreadPoolCallback;
|
|
lOrg: TROInvokerQueueItem;
|
|
begin
|
|
lOrg := TROInvokerQueueItem.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
|
|
TSendEvent = class(TInterfacedObject, IROThreadPoolCallback)
|
|
private
|
|
fStream: TROEventData;
|
|
fOwner: TROCustomSuperTcpServer;
|
|
fWorkerOverride: IROTransport;
|
|
fClientGuid: TGUID;
|
|
fSender: TROEventRepository;
|
|
protected
|
|
procedure Callback(Caller: TROThreadPool; Thread: TThread);
|
|
public
|
|
constructor Create(aOwner: TROCustomSuperTcpServer; aClientGuid: TGUID; aSender: TROEventRepository; aData: TROEventData);
|
|
property WorkerOverride: IROTransport read fWorkerOverride write fWorkerOverride;
|
|
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
procedure TROCustomSuperTcpServer.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 TROCustomSuperTcpServer.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 := TSendEvent.Create(Self, aSessionReference, TROEventRepository(aSender), anEventDataItem);
|
|
if BlockingEvents then
|
|
se.Callback(fThreadPool, nil)
|
|
else
|
|
fThreadPool.QueueItem(se);
|
|
end;
|
|
|
|
procedure TROCustomSuperTcpServer.IntExecute(AThread: {$IFDEF RemObjects_INDY10}TIdContext{$ELSE}TIdPeerThread{$ENDIF});
|
|
var
|
|
fChannel: TROSCServerWorker;
|
|
begin
|
|
fChannel := TROSCServerWorker.Create(Self, AThread.Connection);
|
|
fChannel.MaxPackageSize:= Self.MaxPackageSize;
|
|
fClients.Add(fChannel);
|
|
try
|
|
fChannel.DoExecute;
|
|
finally
|
|
fClients.Remove(fChannel);
|
|
fChannel.Free;
|
|
end;
|
|
end;
|
|
|
|
function TROCustomSuperTcpServer.IntGetActive: Boolean;
|
|
begin
|
|
Result := fActive;
|
|
end;
|
|
|
|
procedure TROCustomSuperTcpServer.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.Bindings.DefaultPort := fPort;
|
|
fIndyServer.Active := true;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROCustomSuperTcpServer.Loaded;
|
|
begin
|
|
inherited;
|
|
IntSetActive(fActive);
|
|
end;
|
|
|
|
procedure TROCustomSuperTcpServer.SetPort(const Value: Integer);
|
|
begin
|
|
fPort := Value;
|
|
if fActive then
|
|
begin
|
|
IntSetActive(False);
|
|
IntSetActive(True);
|
|
end;
|
|
end;
|
|
|
|
procedure TROCustomSuperTcpServer.SetThreadPool(const Value: TROThreadPool);
|
|
begin
|
|
if fOwnsThreadPool then
|
|
begin
|
|
fOwnsThreadPool := false;
|
|
fThreadPool.Free;
|
|
end;
|
|
fThreadPool := Value;
|
|
end;
|
|
|
|
|
|
{ TROSCServerWorker }
|
|
|
|
constructor TROSCServerWorker.Create(aOwner: TROCustomSuperTcpServer;
|
|
aConnection: TIdTCPConnection);
|
|
begin
|
|
fOwner := aOwner;
|
|
inherited Create(aConnection);
|
|
IsServer := true;
|
|
SkipAck := fOwner.Skipack;
|
|
end;
|
|
|
|
destructor TROSCServerWorker.Destroy;
|
|
begin
|
|
while fRefCount > 0 do
|
|
Sleep(500); // we might have events still waiting.
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TROSCServerWorker.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
|
|
begin
|
|
if GetInterface(IID, Obj) then
|
|
Result := 0
|
|
else
|
|
Result := E_NOINTERFACE;
|
|
end;
|
|
|
|
function TROSCServerWorker._AddRef: Integer; stdcall;
|
|
begin
|
|
result := InterlockedIncrement(fRefCount);
|
|
end;
|
|
|
|
function TROSCServerWorker._Release: Integer; stdcall;
|
|
begin
|
|
result := InterlockedDecrement(fRefCount);
|
|
end;
|
|
|
|
function TROSCServerWorker.GetClientAddress : string;
|
|
begin
|
|
{$IFDEF REMOBJECTS_INDY8}
|
|
if (Connection.Binding <> nil) then
|
|
Result := Connection.Binding.PeerIP
|
|
else
|
|
Result := '';
|
|
{$ELSE}
|
|
if (Connection.Socket <> nil) and (Connection.Socket.Binding <> nil) then
|
|
Result := Connection.Socket.Binding.PeerIP
|
|
else
|
|
Result := '';
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TROSCServerWorker.GetTransportObject : TObject;
|
|
begin
|
|
Result := Self;
|
|
end;
|
|
|
|
procedure TROSCServerWorker.IncomingData(Id: Integer; aData: TStream);
|
|
begin
|
|
fOwner.HasData(Id, Self, aData);
|
|
end;
|
|
|
|
procedure TROSCServerWorker.Connected;
|
|
var
|
|
data, rs: Binary;
|
|
evd: TROEventData;
|
|
i, len: Longint;
|
|
|
|
begin
|
|
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
|
|
fOwner.fEventRepository.AddSession(ClientID, Self);
|
|
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;
|
|
|
|
procedure TROSCServerWorker.Disconnected(var RestartLoop: Boolean);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if fEventManager <> nil then
|
|
fEventManager.SessionsChangedNotification(ClientID, saRemoveActiveListener, Self);
|
|
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 TROSCServerWorker.EventsRegistered(aSender : TObject; aClient: TGUID);
|
|
var
|
|
lNew : IROSessionsChangesListener;
|
|
begin
|
|
Supports(aSender, IROSessionsChangesListener, lNew);
|
|
if (fEventManager <> nil) and (lNew <> fEventManager) then begin
|
|
fEventManager.SessionsChangedNotification(ClientID, saRemoveActiveListener, Self);
|
|
end;
|
|
fEventManager := lNew;
|
|
end;
|
|
|
|
procedure TROSCServerWorker.DispatchEvent(anEventDataItem : TROEventData; aSessionReference : TGUID; aSender: TObject);
|
|
var
|
|
se: TSendEvent;
|
|
begin
|
|
se := TSendEvent.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 TSendEvent.Callback(Caller: TROThreadPool; Thread: TThread);
|
|
var
|
|
ms: TROConstantMemoryStream;
|
|
i: Integer;
|
|
wak: IROPackageAck;
|
|
ass: IROActiveEventServer;
|
|
obj: TROSCServerWorker;
|
|
aRef: IROSessionsChangesListener;
|
|
begin
|
|
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 := TROSCServerWorker(fWorkerOverride.GetTransportObject)
|
|
else
|
|
obj := TROSCServerWorker(fOwner.fGuidToClientMap.Objects[i]);
|
|
wak := obj.SendPackage(ms, 0);
|
|
if not Supports(obj, IROSessionsChangesListener, ass) then ass := nil;
|
|
finally
|
|
fOwner.fClients.UnlockList;
|
|
end;
|
|
TROSCServerWorker.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 TSendEvent.Create(aOwner: TROCustomSuperTcpServer; aClientGuid: TGUID; aSender: TROEventRepository; aData: TROEventData);
|
|
begin
|
|
inherited Create;
|
|
fStream := aData;
|
|
fSender := aSender;
|
|
fClientGuid := aClientGuid;
|
|
fOwner := aOwner;
|
|
end;
|
|
|
|
destructor TSendEvent.Destroy;
|
|
begin
|
|
if fStream.RemoveRef = 0 then
|
|
fStream.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TROInvokerQueueItem }
|
|
|
|
procedure TROInvokerQueueItem.Callback(Caller: TROThreadPool; Thread: TThread);
|
|
var
|
|
lResponse: TMemoryStream;
|
|
l: TList;
|
|
begin
|
|
lResponse := TMemoryStream.Create;
|
|
try
|
|
fCaller.DispatchMessage(FClient, fData, lResponse);
|
|
lResponse.Seek(0, soFromBeginning);
|
|
l := fCaller.fClients.LockList;
|
|
try
|
|
if l.IndexOf(FClient) = -1 then exit;
|
|
FClient.BeginWriteLock;
|
|
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
|
|
FClient.EndWriteLock;
|
|
end;
|
|
finally
|
|
lResponse.Free;
|
|
end;
|
|
end;
|
|
|
|
constructor TROInvokerQueueItem.Create(aCaller: TROCustomSuperTcpServer; aClient: TROSCServerWorker; Id: Integer; aData: TStream);
|
|
begin
|
|
inherited Create;
|
|
fCaller := aCaller;
|
|
fId := Id;
|
|
fData := aData;
|
|
fClient := aClient;
|
|
end;
|
|
|
|
destructor TROInvokerQueueItem.Destroy;
|
|
begin
|
|
fData.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
initialization
|
|
RegisterServerClass(TROSuperTcpServer);
|
|
finalization
|
|
UnregisterServerClass(TROSuperTcpServer);
|
|
end.
|