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.