unit uROServer;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Core 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
  Classes, SysUtils, SyncObjs,
  {$IFDEF REMOBJECTS_TRIAL}uROTrial, {$ENDIF}
  {$IFDEF REMOBJECTS_UseEncryption}uROEncryption, {$ENDIF}
  uRORes, uROServerIntf, uROClient, uROClientIntf, uROClasses, uROTypes,
  uROEventRepository;

type
  TROServer = class;

  { TMessageInvokeMethod }
  TMessageInvokeMethod = procedure(const anInstance: IInterface;
    const aMessage: IROMessage;
    const aTransport: IROTransport;
    out oResponseOptions:TROResponseOptions) of object;

  { TRORemotable }
  TRORemotable = class(TInterfacedObject, IROObjectRetainer)
  private
    fRetainedObjects : TList;
    
  protected
    {$IFDEF DELPHI7UP}
    procedure Synchronize(aMethod: TThreadMethod);
    {$ENDIF DELPHI7UP}

    { IROObjectRetainer  }
    procedure RetainObject(const anObject : TObject);
    procedure ReleaseObject(const anObject : TObject);
    function IsRetained(const anObject : TObject) : boolean;

  public
    constructor Create; virtual;
    destructor Destroy; override;
  end;

  TRORemotableClass = class of TRORemotable;

  { TROInvoker }
  {$M+}
  TROInvoker = class(TInterfacedObject, IROInvoker)
  private

  protected
    function CustomHandleMessage(const aFactory: IROClassFactory;
      const aMessage: IROMessage;
      const aTransport: IROTransport;
      out oResponseOptions: TROResponseOptions): boolean; virtual;

    procedure BeforeInvoke(aMethodPtr: TMessageInvokeMethod;
      const anInstance: IInterface;
      const aFactory: IROClassFactory;
      const aMessage: IROMessage;
      const aTransport: IROTransport); virtual;

    procedure AfterInvoke(aMethodPtr: TMessageInvokeMethod;
      const anInstance: IInterface;
      const aFactory: IROClassFactory;
      const aMessage: IROMessage;
      const aTransport: IROTransport;
      anException: Exception); virtual;

  public
    constructor Create; virtual;
    destructor Destroy; override;

    function HandleMessage(const aFactory: IROClassFactory;
      const aMessage: IROMessage;
      const aTransport: IROTransport;
      out oResponseOptions: TROResponseOptions): boolean;

  published
    { IROServerEventsBroker invocation - Ghost methods }
    procedure Invoke_RegisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
    procedure Invoke_UnregisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
    procedure Invoke_RegisterClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
    procedure Invoke_UnregisterClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
    procedure Invoke_GetEventsData(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
  end;
  {$M-}

  TROInvokerClass = class of TROInvoker;

  { TROClassFactory }
  TRORemotableCreatorFunc = procedure(out anInstance: IInterface);

  { TROMessageDispatcher }
  TROMessageDispatchers = class;
  TROMessageDispatcher = class(TCollectionItem)
  private
    fDispatchers: TROMessageDispatchers;
    fMessage: TROMessage;
    fEnabled: boolean;
    fDummyName: string;

    fMessageIntf: pointer;
    fModuleInfoIntf: pointer;

    function GetMessageIntf: IROMessage;
    function GetModuleInfoIntf: IROModuleInfo;
    function GetServer: TROServer;

  protected
    procedure SetMessage(const Value: TROMessage); virtual;
    function GetDisplayName: string; override;

    property Server:TROServer read GetServer;

  public
    constructor Create(aCollection: TCollection); override;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;

    function ProcessMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
    function CanHandleMessage(const aTransport: IROTransport; aRequeststream: TStream): boolean; virtual;

    property MessageIntf: IROMessage read GetMessageIntf;
    property ModuleIntf: IROModuleInfo read GetModuleInfoIntf;
  published
    property Name: string read GetDisplayName write fDummyName;
    property Message: TROMessage read fMessage write SetMessage;
    property Enabled: boolean read fEnabled write fEnabled;
  end;

  TROMessageDispatcherClass = class of TROMessageDispatcher;

  { TROMessageDispatchers }

  TROMessageDispatchers = class(TCollection)
  private
    fServer: TROServer;

    function GetDispatcher(Index: integer): TROMessageDispatcher;

  protected
    function GetSupportsMultipleDispatchers: boolean; virtual;
    function GetDispatcherClass: TROMessageDispatcherClass; virtual;
    {$IFDEF DELPHI6UP}
    procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;
    {$ENDIF DELPHI6UP}
    property Server:TROServer read fServer;

  public
    constructor Create(aServer: TROServer); virtual;
    destructor Destroy; override;

    procedure CleanReferences(aMessage: TROMessage);
    function FindDuplicate(aMessage: TROMessage): TROMessageDispatcher;
    function FindDispatcher(const aTransport: IROTransport; aRequestStream: TStream): TROMessageDispatcher;

    function DispatcherByName(const aName: string): TROMessageDispatcher;

    property Dispatchers[Index: integer]: TROMessageDispatcher read GetDispatcher; default;
    property SupportsMultipleDispatchers: boolean read GetSupportsMultipleDispatchers;
  end;

  TROMessageDispatchersClass = class of TROMessageDispatchers;

  { TROServer }
  TROGetRODLReader = procedure (Sender: TROServer; var aRODLReader: TROCustomRODLReader) of object;

  {$IFDEF REMOBJECTS_UseEncryption}
  TROServer = class(TROBaseConnection)
  {$ELSE}
  TROServer = class(TROComponent)
  {$ENDIF}
  private
    fDoneAfterLoad,
      fLoadActive: boolean;

    fOnAfterServerDeactivate: TNotifyEvent;
    fOnAfterServerActivate: TNotifyEvent;
    fOnBeforeServerDeactivate: TNotifyEvent;
    fOnBeforeServerActivate: TNotifyEvent;
    fDispatchers: TROMessageDispatchers;
    fOnReadFromStream: TStreamOperation;
    fOnWriteToStream: TStreamOperation;
    FOnGetRODLReader: TROGetRODLReader;
       //fAsyncResponseStorage: TROAsyncResponseStorage;

    function GetActive: boolean;
    procedure SetActive(const Value: boolean);
    procedure SetDispatchers(const Value: TROMessageDispatchers);
       //procedure SetAsyncResponseStorage(const Value:TROAsyncResponseStorage);

  private
    procedure TriggerReadFromStream(iStream: TStream);
    procedure TriggerWriteToStream(iStream: TStream);

  protected
    { Internals }
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;

    procedure IntSetActive(const Value: boolean); virtual; abstract;
    function IntGetActive: boolean; virtual; abstract;

    procedure Loaded; override;

    function GetDispatchersClass: TROMessageDispatchersClass; virtual;

    function DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream): boolean; overload;
    function DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean; overload;

    function IntDispatchMessage(Dispatcher: TROMessageDispatcher; const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
    property OnGetRODLReader: TROGetRODLReader read FOnGetRODLReader write FOnGetRODLReader;
    function GetRODLReader: TROCustomRODLReader;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure CheckProperties; virtual;
  published
    property Active: boolean read GetActive write SetActive default false;
    //property AsyncResponseStorage:TROAsyncResponseStorage read fAsyncResponseStorage write SetAsyncResponseStorage;

    property Dispatchers: TROMessageDispatchers read fDispatchers write SetDispatchers;

    property OnBeforeServerActivate: TNotifyEvent read fOnBeforeServerActivate write fOnBeforeServerActivate;
    property OnAfterServerActivate: TNotifyEvent read fOnAfterServerActivate write fOnAfterServerActivate;
    property OnBeforeServerDeactivate: TNotifyEvent read fOnBeforeServerDeactivate write fOnBeforeServerDeactivate;
    property OnAfterServerDeactivate: TNotifyEvent read fOnAfterServerDeactivate write fOnAfterServerDeactivate;
    property OnWriteToStream: TStreamOperation read fOnWriteToStream write fOnWriteToStream;
    property OnReadFromStream: TStreamOperation read fOnReadFromStream write fOnReadFromStream;
  end;

  TROServerClass = class of TROServer;

  TROClassFactory = class(TInterfacedObject, IROClassFactory)
  private
    fCreatorFunc: TRORemotableCreatorFunc;
    fInterfaceName: string;
    fInvoker: IROInvoker;
    fInvokerClass: TROInvokerClass;

  protected
       { IROClassFactory }
    procedure CreateInstance(const aClientID: TGUID; out anInstance: IInterface); virtual;
    procedure ReleaseInstance(const aClientID: TGUID; var anInstance: IInterface); virtual;

       {procedure ActivateInstance(const aClientID:TGUID; const anInstance:IInterface);
       procedure DeactivateInstance(const aClientID:TGUID; const anInstance:IInterface);}

    function GetInterfaceName: string;
    function GetInvoker: IROInvoker;

    property CreatorFunc: TRORemotableCreatorFunc read fCreatorFunc;

  public
    constructor Create(const anInterfaceName: string;
      aCreatorFunc: TRORemotableCreatorFunc;
      anInvokerClass: TROInvokerClass);
    destructor Destroy; override;
  end;

  EROSendNoResponse = class(EROException);

procedure ROSendNoResponse;

function MainProcessMessage(
  const aMessage: IROMessage;
  const aTransport: IROTransport;
  aRequestStream,
  aResponseStream: TStream;
  out oResponseOptions: TROResponseOptions): boolean;

procedure RegisterClassFactory(const aClassFactory: IROClassFactory);
procedure UnRegisterClassFactory(const aClassFactory: IROClassFactory);
function GetClassFactory(const anInterfaceName: string): IROClassFactory;
function FindClassFactory(const anInterfaceName: string): IROClassFactory; {$IFDEF VER140UP} deprecated; {$ENDIF} // Please use GetClassFactory. mh.
function TryFindClassFactory(const anInterfaceName: string): IROClassFactory;
function IsClassFactoryRegistered(const anInterfaceName: string):boolean;
function GetClassFactoryNames:IROStrings;

procedure RegisterServerClass(aROMessageClass: TROServerClass);
procedure UnregisterServerClass(aROMessageClass: TROServerClass);
function GetServerClass(Index: integer): TROServerClass;
function GetServerClassCount: integer;

implementation

uses
  Contnrs;

procedure ROSendNoResponse;
begin
  {
    NOTE

    This exception is expected to be raised if you use the ROSendNoResponse
    function in your asynchronous/broadcast channels. YOu can safely ignore
    when the Delphi IDE breaks on this line, and you can add it to the ist
    of "Silent" exceptions under Tools|Debugger Options|Language Exceptions.
  }
  raise EROSendNoResponse.Create('');
end;

var
  _ServerClasses: TClassList;

procedure RegisterServerClass(aROMessageClass: TROServerClass);
begin
  _ServerClasses.Add(aROMessageClass);
end;

procedure UnregisterServerClass(aROMessageClass: TROServerClass);
begin
  _ServerClasses.Remove(aROMessageClass);
end;

function GetServerClass(Index: integer): TROServerClass;
begin
  result := TROServerClass(_ServerClasses[Index]);
end;

function GetServerClassCount: integer;
begin
  result := _ServerClasses.Count
end;

type
  TROClassFactoryList = class(TInterfaceList)
  private
    function GetItems(Index: integer): IROClassFactory;
  protected
  public
    function Add(aClassFactory: IROClassFactory): integer;
    function GetClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
    function FindClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
    function GetNames:IROStrings;
    property Items[Index: integer]: IROClassFactory read GetItems; default;
  end;

var
  _ClassFactoryList: TROClassFactoryList;

function ClassFactoryList: TROClassFactoryList;
begin
  if (_ClassFactoryList = nil) then _ClassFactoryList := TROClassFactoryList.Create;
  result := _ClassFactoryList;
end;

function MainProcessMessage(const aMessage: IROMessage; const aTransport: IROTransport; aRequestStream, aResponseStream: TStream; out oResponseOptions: TROResponseOptions): boolean;
var
  factory: IROClassFactory;
  moduleinfo: IROModuleInfo;
  dataformat: TDataFormat;
  http: IROHTTPTransport;
begin
  oResponseOptions := [];
//  result := FALSE; // reenabled because of a compiler warning

  try
    if (aMessage = nil) then RaiseError(err_NILMessage, []);

    case aRequestStream.Size of
      // Metadata retrieval
      MetadataRequestIDLength : begin
        oResponseOptions := oResponseOptions + [roDontEncrypt];
        DataFormat := 'text/xml';
        if Supports(aMessage, IROModuleInfo, moduleinfo) then
          moduleinfo.GetRodlInfo(aResponseStream, aTransport, dataformat)
        else
          RaiseError(err_InvalidRequestStream, [aRequestStream.Size]);
        if supports(aTransport, IROHttpTransport, http) then
          http.ContentType := dataformat;

        result := TRUE;
      end;
      0 : begin
        oResponseOptions := oResponseOptions + [roDontEncrypt];
        DataFormat := 'text/xml';
        if Supports(aMessage, IROModuleInfo, moduleinfo) then
          moduleinfo.GetModuleInfo(aResponseStream, aTransport, dataformat)
        else
          RaiseError(err_InvalidRequestStream, [aRequestStream.Size]);
        if supports(aTransport, IROHttpTransport, http) then
          http.ContentType := dataformat;
        result := TRUE;
      end;

      // Probing
      ProbeRequestIDLength : begin
        aResponseStream.Write(ProbeResponseID, ProbeResponseIDLength);
        Result := TRUE;
      end;

      // Messages
      else begin
        aMessage.InitializeRead(aTransport);
        aMessage.ReadFromStream(aRequestStream);

        case aMessage.MessageType of
          mtPoll: begin
              if IsEqualGUID(aMessage.ClientID, EmptyGUID) then
                raise EROServerException.Create('Poll messages may not be sent with empty Client ID.');

              raise EROServerException.Create('.NET-style polling is not implemented in RO/Delphi, yet.');
            end;

          mtRequest, mtResponse: begin
              if (aMessage.InterfaceName = '') then
                RaiseError(err_UnspecifiedInterface, [])
              else if (aMessage.MessageName = '') then
                RaiseError(err_UnspecifiedMessage, [])
              else if IsEqualGUID(aMessage.ClientID, EmptyGUID) then
                aMessage.ClientID := NewGuid();

              if IsEqualGUID(aMessage.ClientID, EmptyGUID) then
                aMessage.ClientID := NewGuid();

              factory := GetClassFactory(aMessage.InterfaceName);
              result := factory.Invoker.HandleMessage(factory, aMessage, aTransport, oResponseOptions);

              aMessage.WriteToStream(aResponseStream);
            end;

          else begin
            raise EROServerException.CreateFmt('Unsupported messages type %d.', [integer(aMessage.MessageType)]);
          end;

        end;

      end;
    end;
  except
    on E: EROSendNoResponse do begin
      result := FALSE;
      oResponseOptions := oResponseOptions + [roNoResponse];
      aMessage.InitializeExceptionMessage(aTransport, '', aMessage.InterfaceName, aMessage.MessageName);
      aMessage.WriteException(aResponseStream, E);
    end;
    on E: Exception do begin
      result := FALSE;
      aMessage.InitializeExceptionMessage(aTransport, '', aMessage.InterfaceName, aMessage.MessageName);
      aMessage.WriteException(aResponseStream, E);
    end;
  end;
end;

function GetClassFactory(const anInterfaceName: string): IROClassFactory;
begin
  result := ClassFactoryList.GetClassFactoryByInterfaceName(anInterfaceName);
end;

function FindClassFactory(const anInterfaceName: string): IROClassFactory;
begin
  result := ClassFactoryList.GetClassFactoryByInterfaceName(anInterfaceName);
end;

function TryFindClassFactory(const anInterfaceName: string): IROClassFactory;
begin
  result := ClassFactoryList.FindClassFactoryByInterfaceName(anInterfaceName);
end;

function IsClassFactoryRegistered(const anInterfaceName: string):boolean;
begin
  result := assigned(_ClassFactoryList) and assigned(ClassFactoryList.FindClassFactoryByInterfaceName(anInterfaceName));
end;

function GetClassFactoryNames:IROStrings;
begin
  result := ClassFactoryList.GetNames();
end;

procedure RegisterClassFactory(const aClassFactory: IROClassFactory);
begin
  ClassFactoryList.Add(aClassFactory);
end;

procedure UnRegisterClassFactory(const aClassFactory: IROClassFactory);
begin
  if assigned(_ClassFactoryList) then
    _ClassFactoryList.Remove(aClassFactory);
end;

{ TROClassFactoryList }

function TROClassFactoryList.Add(aClassFactory: IROClassFactory): integer;
begin
  { ToDo: make sure no other class factopry is registered yet, that serves
          the same class name
          http://www.remobjects.com/bugdb?bug=E14CD985-B996-45A3-B480-7C22F09093F5 }

  result := inherited Add(aClassFactory);
end;

function TROClassFactoryList.GetClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
begin
  result := FindClassFactoryByInterfaceName(anInterfaceName);
  if not Assigned(result) then RaiseError(err_ClassFactoryNotFound, [anInterfaceName]);
end;

function TROClassFactoryList.FindClassFactoryByInterfaceName(const anInterfaceName: string): IROClassFactory;
var
  i:integer;
begin
  result := nil;
  for i := 0 to (Count - 1) do
    if (CompareText(anInterfaceName, Items[i].GetInterfaceName) = 0) then begin
      result := Items[i];
      Break;
    end;
end;

function TROClassFactoryList.GetItems(Index: integer): IROClassFactory;
begin
  result := inherited Items[Index] as IROClassFactory
end;

function TROClassFactoryList.GetNames: IROStrings;
var
  i:integer;
begin
  result := NewROStrings();
  for i := 0 to Count-1 do begin
    Result.Add(Items[i].InterfaceName)
  end;
end;

{ TROInvoker }

constructor TROInvoker.Create;
begin
  inherited Create;
end;

procedure TROInvoker.BeforeInvoke(aMethodPtr: TMessageInvokeMethod;
  const anInstance: IInterface;
  const aFactory: IROClassFactory;
  const aMessage: IROMessage;
  const aTransport: IROTransport);
var
  dispnotifier: IRODispatchNotifier;
  objactivation: IROObjectActivation;
  streamaccess : IROStreamAccess;
  currpos : integer;
begin
  streamaccess := NIL;
  currpos := -1; // introduced for a compiler warning...

  if Supports(aMessage, IROStreamAccess, streamaccess)
    then currpos := streamaccess.Stream.Position;

  // This can be enanched by descendants
  if Supports(anInstance, IROObjectActivation, objactivation) then begin
    objactivation.OnActivate(aMessage.ClientID, aMessage);
    if (streamaccess<>NIL)
      then streamaccess.Stream.Position := currpos;
  end;

  if Supports(anInstance, IRODispatchNotifier, dispnotifier) then begin
    dispnotifier.GetDispatchInfo(aTransport, aMessage);
    if (streamaccess<>NIL)
      then streamaccess.Stream.Position := currpos;
  end;
end;

procedure TROInvoker.AfterInvoke(aMethodPtr: TMessageInvokeMethod;
  const anInstance: IInterface;
  const aFactory: IROClassFactory;
  const aMessage: IROMessage;
  const aTransport: IROTransport;
  anException: Exception);
var
  objactivation: IROObjectActivation;
begin
  if Supports(anInstance, IROObjectActivation, objactivation) then begin
    objactivation.OnDeactivate(aMessage.ClientID);
  end;
end;

function TROInvoker.CustomHandleMessage(const aFactory: IROClassFactory;
  const aMessage: IROMessage;
  const aTransport: IROTransport;
  out oResponseOptions: TROResponseOptions): boolean;
var
  mtd: TMessageInvokeMethod;
  instance: IInterface;
begin
  result := FALSE;

  mtd := nil;
  instance := nil;

  // The message is guaranteed not to be NIL and to have a name and an InterfaceName at this point
  @mtd := MethodAddress('Invoke_' + aMessage.MessageName);
  if (@mtd <> nil) then try
    try
      aFactory.CreateInstance(aMessage.ClientID, instance);

      if (instance = nil) then RaiseError(err_ClassFactoryDidNotReturnInstance, [aMessage.InterfaceName]);

      BeforeInvoke(mtd, instance, aFactory, aMessage, aTransport);
      mtd(instance, aMessage, aTransport, oResponseOptions);
      AfterInvoke(mtd, instance, aFactory, aMessage, aTransport, nil);

      result := TRUE;
    except
      on E: Exception do begin
        AfterInvoke(mtd, instance, aFactory, aMessage, aTransport, E);
        raise;
      end;
    end;
  finally
    if (instance <> nil) then aFactory.ReleaseInstance(aMessage.ClientID, instance);
  end
  else
    RaiseError(err_UnknownMethod, [aMessage.MessageName, aFactory.InterfaceName]);
end;

destructor TROInvoker.Destroy;
begin
  inherited;
end;

function TROInvoker.HandleMessage(const aFactory: IROClassFactory;
  const aMessage: IROMessage;
  const aTransport: IROTransport;
  out oResponseOptions: TROResponseOptions): boolean;
begin
  result := CustomHandleMessage(aFactory, aMessage, aTransport, oResponseOptions);
end;

procedure TROInvoker.Invoke_RegisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
{ procedure RegisterEventClient(const ClientID: String; const EventTypes: String); }
var
  ClientID: String;
  EventTypes: String;
begin
  try
    __Message.Read('ClientID', TypeInfo(String), ClientID, []);
    __Message.Read('EventTypes', TypeInfo(String), EventTypes, []);

    (__Instance as IROServerEventsBroker).RegisterEventClient(ClientID, EventTypes);

    __Message.InitializeResponseMessage(__Transport, 'ChatLibrary', 'ChatService', 'RegisterEventClientResponse');
    __Message.Finalize;

    __oResponseOptions := [roNoResponse];

  finally
  end;
end;

procedure TROInvoker.Invoke_UnregisterEventClient(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
{ procedure UnregisterEventClient(const ClientID: String; const EventTypes: String); }
var
  ClientID: String;
  EventTypes: String;
begin
  try
    __Message.Read('ClientID', TypeInfo(String), ClientID, []);
    __Message.Read('EventTypes', TypeInfo(String), EventTypes, []);

    (__Instance as IROServerEventsBroker).UnregisterEventClient(ClientID, EventTypes);

    __Message.InitializeResponseMessage(__Transport, 'ChatLibrary', 'ChatService', 'UnregisterEventClientResponse');
    __Message.Finalize;

    __oResponseOptions := [roNoResponse];

  finally
  end;
end;

procedure TROInvoker.Invoke_GetEventsData(const __Instance:IInterface; const __Message:IROMessage; const __Transport:IROTransport; out __oResponseOptions:TROResponseOptions);
{ function GetEventsData(const ClientID: String; out EventsData: Binary): Integer; }
var
  ClientID: String;
  EventsData: Binary;
  lResult: Integer;
begin
  EventsData := nil;
  try
    __Message.Read('ClientID', TypeInfo(String), ClientID, []);

    lResult := (__Instance as IROServerEventsBroker).GetEventsData(ClientID, EventsData);

    __Message.InitializeResponseMessage(__Transport, 'ChatLibrary', 'ChatService', 'GetEventsDataResponse');
    __Message.Write('Result', TypeInfo(Integer), lResult, []);
    __Message.Write('EventsData', TypeInfo(Binary), EventsData, []);
    __Message.Finalize;

  finally
    EventsData.Free;
  end;
end;

procedure TROInvoker.Invoke_RegisterClient(const __Instance: IInterface;
  const __Message: IROMessage; const __Transport: IROTransport;
  out __oResponseOptions: TROResponseOptions);
begin
  Invoke_RegisterEventClient(__Instance, __Message, __Transport, __oResponseOptions);
end;

procedure TROInvoker.Invoke_UnregisterClient(const __Instance: IInterface;
  const __Message: IROMessage; const __Transport: IROTransport;
  out __oResponseOptions: TROResponseOptions);
begin
  Invoke_UnregisterEventClient(__Instance, __Message, __Transport, __oResponseOptions);
end;

{ TRORemotable }

constructor TRORemotable.Create;
begin
  inherited;
end;

destructor TRORemotable.Destroy;
begin
  FreeAndNIL(fRetainedObjects);
  inherited;
end;

{$IFDEF DELPHI7UP}

procedure TRORemotable.Synchronize(aMethod: TThreadMethod);
begin
  TThread.Synchronize(nil, aMethod);
end;
{$ENDIF DELPHI7UP}

function TRORemotable.IsRetained(const anObject: TObject): boolean;
begin
  result := (fRetainedObjects<>NIL) and (fRetainedObjects.IndexOf(anObject)>=0)
end;

procedure TRORemotable.RetainObject(const anObject: TObject);
begin
  // Only creates it if necessary
  if (fRetainedObjects=NIL) then
    fRetainedObjects := TList.Create;

  fRetainedObjects.Add(anObject);
end;

procedure TRORemotable.ReleaseObject(const anObject: TObject);
var idx : integer;
begin
  // Only creates it if necessary
  if (fRetainedObjects=NIL) then Exit;

  idx := fRetainedObjects.IndexOf(anObject);
  if (idx>=0) then fRetainedObjects.Delete(idx);
end;

{ TROMessageDispatcher }

constructor TROMessageDispatcher.Create(aCollection: TCollection);
begin
  inherited Create(aCollection);

  fEnabled := TRUE;
  fDispatchers := TROMessageDispatchers(aCollection);
  fModuleInfoIntf := nil;
  fMessageIntf := nil;
end;

destructor TROMessageDispatcher.Destroy;
begin
  fModuleInfoIntf := nil;
  fMessageIntf := nil;
  Message := nil;
  inherited;
end;

function TROMessageDispatcher.ProcessMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
var
  lMessage: IROMessage;
begin
  lMessage := (MessageIntf as IROMessageCloneable).Clone();
  result := MainProcessMessage(lMessage, aTransport, aRequeststream, aResponsestream, oResponseOptions);
end;

function TROMessageDispatcher.GetDisplayName: string;
begin
  if (fMessage = nil) then
    result := '[Unassigned]'
  else
    result := fMessage.Name;
end;

function TROMessageDispatcher.GetMessageIntf: IROMessage;
begin
  result := IROMessage(fMessageIntf);
end;

function TROMessageDispatcher.GetModuleInfoIntf: IROModuleInfo;
begin
  result := IROModuleInfo(fModuleInfoIntf)
end;

procedure TROMessageDispatcher.SetMessage(const Value: TROMessage);
var
  ref: IROMessage;
begin
  if (Value = fMessage) then Exit;

  if (Value <> nil) then begin
    if (fDispatchers.FindDuplicate(Value) <> nil) then RaiseError(err_DispatcherAlreadyAssigned, [Value.Name]);
    if not Value.GetInterface(IROMessage, ref) then RaiseError(err_IROMessageNotSupported, [Value.ClassName]);

    fMessageIntf := pointer(ref);
    Value.GetInterface(IROModuleInfo, fModuleInfoIntf);
    Value.FreeNotification(Server);

  end
  else begin
    fMessageIntf := nil;
    fModuleInfoIntf := nil;
  end;

  fMessage := Value;
end;

function TROMessageDispatcher.CanHandleMessage(const aTransport: IROTransport; aRequeststream: TStream): boolean;
begin
  result := fEnabled;
end;

procedure TROMessageDispatcher.Assign(Source: TPersistent);
var
  SourceDispatcher: TROMessageDispatcher;
begin
  if Source is TROMessageDispatcher then begin
    SourceDispatcher := TROMessageDispatcher(Source);
    Name := SourceDispatcher.Name;
    Message := SourceDispatcher.Message;
    Enabled := SourceDispatcher.Enabled;
  end
  else
    inherited Assign(Source);
end;

function TROMessageDispatcher.GetServer: TROServer;
begin
  result := fDispatchers.Server;
end;

{ TROMessageDispatchers }

procedure TROMessageDispatchers.CleanReferences(aMessage: TROMessage);
var
  i: integer;
begin
  for i := 0 to (Count - 1) do
    if (Dispatchers[i].Message = aMessage) then begin
      Dispatchers[i].Message := nil;
    end;
end;

constructor TROMessageDispatchers.Create(aServer: TROServer);
begin
  inherited Create(GetDispatcherClass);
  fServer := aServer;
end;

destructor TROMessageDispatchers.Destroy;
begin
  inherited;
end;

function TROMessageDispatchers.FindDispatcher(const aTransport: IROTransport;
  aRequestStream: TStream): TROMessageDispatcher;
var
  i: integer;
begin
  result := nil;

  for i := 0 to (Count - 1) do
    if Dispatchers[i].CanHandleMessage(aTransport, aRequestStream) then begin
      result := Dispatchers[i];
      Break;
    end;
end;

function TROMessageDispatchers.DispatcherByName(
  const aName: string): TROMessageDispatcher;
var
  i: integer;
begin
  result := nil;
  for i := 0 to (Count - 1) do
    if (CompareText(Dispatchers[i].Name, aName) = 0) then begin
      result := Dispatchers[i];
      Exit;
    end;
end;

function TROMessageDispatchers.FindDuplicate(
  aMessage: TROMessage): TROMessageDispatcher;
var
  i: integer;
begin
  result := nil;

  for i := 0 to (Count - 1) do
    if (Dispatchers[i].Message = aMessage) then begin
      result := Dispatchers[i];
      Exit;
    end;
end;

function TROMessageDispatchers.GetDispatcher(
  Index: integer): TROMessageDispatcher;
begin
  result := TROMessageDispatcher(inherited Items[Index]);
end;

function TROMessageDispatchers.GetDispatcherClass: TROMessageDispatcherClass;
begin
  result := TROMessageDispatcher;
end;

function TROMessageDispatchers.GetSupportsMultipleDispatchers: boolean;
begin
  result := FALSE;
end;

{$IFDEF DELPHI6UP}

procedure TROMessageDispatchers.Notify(Item: TCollectionItem;
  Action: TCollectionNotification);
begin
  inherited;
  if (Action = cnAdded) then begin
    if not SupportsMultipleDispatchers and (Count > 1) then begin

      (*if (csDesigning in fServer.ComponentState) then begin
        { TODO: This is really bad. I should probabily just make a component editor and control it in there.
                The problem is that I cannot find a way to stop a TCollection.Add method gracefully.
                After this method is called TCollection.InsertItem continues and invokes NotifyDesigner
                passing Item. That will obviously fail since Item is being freed here... }
        MessageDlg(Format(err_ServerOnlySupportsOneDispatcher+'.'+#13#10+
                          'You can ignore the error that Delphi will raise in the IDE after you close this dialog.', [fServer.ClassName]), mtError, [mbOK], 0);
      end;*)

      FreeAndNIL(Item);
      RaiseError(err_ServerOnlySupportsOneDispatcher, [])
    end;
  end;
end;
{$ENDIF DELPHI6UP}

{ TROServer }

constructor TROServer.Create(aOwner: TComponent);
begin
  inherited;
  fDispatchers := GetDispatchersClass.Create(Self);
end;

destructor TROServer.Destroy;
begin
  fDispatchers.Free;
  inherited;
end;

procedure TROServer.TriggerReadFromStream(iStream: TStream);
begin
  if Assigned(OnReadFromStream) then begin
    iStream.Position := 0;
    OnReadFromStream(iStream);
    iStream.Position := 0;
  end;
end;

procedure TROServer.TriggerWriteToStream(iStream: TStream);
begin
  if Assigned(OnWriteToStream) then begin
    iStream.Position := 0;
    OnWriteToStream(iStream);
    iStream.Position := 0;
  end;
end;

function TROServer.DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream): boolean;
var
  lIgnore: TROResponseOptions;
begin
  result := DispatchMessage(aTransport, aRequeststream, aResponsestream, lIgnore);
end;

function TROServer.DispatchMessage(const aTransport: IROTransport; aRequeststream, aResponsestream: TStream; out oResponseOptions: TROResponseOptions): boolean;
var
  dispatcher: TROMessageDispatcher;
  excstr: string;
begin
  result := false;
  try
    {aRequeststream.Position := 0;
    if Assigned(OnReadFromStream) then OnReadFromStream(aRequeststream);
    aRequeststream.Position := 0;}

    dispatcher := Dispatchers.FindDispatcher(aTransport, aRequeststream);

    if (dispatcher = nil) then RaiseError(err_CannotFindMessageDispatcher, []); // Should never happen! If this happens there's no way to format the exception correctly

    result := IntDispatchMessage(dispatcher, aTransport, aRequeststream, aResponsestream, oResponseOptions);

  except
    on E: Exception do begin
      if (E.Message <> '') then
        excstr := E.Message
      else
        excstr := err_UnhandledException;
      aResponseStream.Write(excstr[1], Length(excstr));
      TriggerWriteToStream(aResponsestream);
    end;
  end;

  aResponsestream.Position := 0; // Just in case
  {aResponsestream.Position := 0;
  if Assigned(OnWriteToStream) then OnWriteToStream(aResponsestream);
  aResponsestream.Position := 0;}
end;

function TROServer.GetActive: boolean;
begin
  result := IntGetActive;
end;

procedure TROServer.Loaded;
begin
  inherited;

  IntSetActive(FALSE);
  Active := fLoadActive;
  fDoneAfterLoad := TRUE;
end;

procedure TROServer.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;

  if (Operation = opRemove) then begin
    if (aComponent is TROMessage) then fDispatchers.CleanReferences(TROMessage(aComponent));
    //if aComponent = AsyncResponseStorage then AsyncResponseStorage := nil;
  end;
end;

procedure TROServer.SetActive(const Value: boolean);
begin
  if (csLoading in ComponentState) then begin
    fDoneAfterLoad := FALSE;
    fLoadActive := Value
  end

  else begin
    if (Value = Active) then Exit;

    case Value of
      TRUE: if Assigned(fOnBeforeServerActivate) then fOnBeforeServerActivate(Self);
      FALSE: if Assigned(fOnBeforeServerDeactivate) then fOnBeforeServerDeactivate(Self);
    end;

    IntSetActive(Value);

    if (Value = Active) then begin
      case Value of
        TRUE: if Assigned(fOnAfterServerActivate) then fOnAfterServerActivate(Self);
        FALSE: if Assigned(fOnAfterServerDeactivate) then fOnAfterServerDeactivate(Self);
      end;
    end;
  end;
end;

procedure TROServer.SetDispatchers(const Value: TROMessageDispatchers);
begin
  fDispatchers := Value;
end;

function TROServer.GetDispatchersClass: TROMessageDispatchersClass;
begin
  result := TROMessageDispatchers;      // Default
end;

{procedure TROServer.SetAsyncResponseStorage(const Value:TROAsyncResponseStorage);
begin
  if fAsyncResponseStorage <> Value then begin
    fAsyncResponseStorage := Value;
    if Assigned(fAsyncResponseStorage) then fAsyncResponseStorage.FreeNotification(self);
  end;
end;}

function TROServer.IntDispatchMessage(Dispatcher: TROMessageDispatcher;
  const aTransport: IROTransport; aRequeststream, aResponsestream: TStream;
  out oResponseOptions: TROResponseOptions): boolean;
  {$IFDEF REMOBJECTS_UseEncryption}
var
  DEncRequest, DUnEncResponse: TMemoryStream;
  {$ENDIF}
begin
  {$IFDEF REMOBJECTS_UseEncryption}
  if Encryption.EncryptionMethod <> tetNone then begin
    dEncRequest := TMemoryStream.Create;
    dUnEncResponse := TMemoryStream.Create;
    try
      DoDecryption(aRequeststream, dEncRequest);
      DEncRequest.Position := 0;
      TriggerReadFromStream(dEncRequest);
      result := dispatcher.ProcessMessage(aTransport, dEncRequest, dUnEncResponse, oResponseOptions); // This traps exception and cannot fail
      TriggerWriteToStream(dUnEncResponse);
      if roDontEncrypt in oResponseOptions then
      begin
        DUnEncResponse.Position := 0;
        aResponsestream.CopyFrom(DUnEncResponse, DUnEncResponse.Size);
        aResponsestream.Position := 0;
      end else
      DoEncryption(dUnEncResponse, aResponsestream);
    finally
      dEncRequest.Free;
      dUnEncResponse.free;
    end;
  end
  else
  {$ENDIF}
  begin
    TriggerReadFromStream(aRequeststream);
    result := dispatcher.ProcessMessage(aTransport, aRequeststream, aResponsestream, oResponseOptions); // This traps exception and cannot fail
    TriggerWriteToStream(aResponsestream);
  end;
end;

procedure TROServer.CheckProperties;
begin
// nothing
end;

function TROServer.GetRODLReader: TROCustomRODLReader;
begin
  Result:=nil;
  if Assigned(FOnGetRODLReader) then FOnGetRODLReader(Self,Result);
end;

{ TROClassFactory }

constructor TROClassFactory.Create(const anInterfaceName: string;
  aCreatorFunc: TRORemotableCreatorFunc;
  anInvokerClass: TROInvokerClass);
begin
  inherited Create;

  fInvoker := nil;
  fCreatorFunc := aCreatorFunc;
  fInterfaceName := anInterfaceName;
  fInvokerClass := anInvokerClass;

  RegisterClassFactory(Self);
end;

destructor TROClassFactory.Destroy;
begin
  inherited;
end;

procedure TROClassFactory.CreateInstance(const aClientID: TGUID; out anInstance: IInterface);
begin
  fCreatorFunc(anInstance);
end;

function TROClassFactory.GetInterfaceName: string;
begin
  result := fInterfaceName
end;

function TROClassFactory.GetInvoker: IROInvoker;
begin
  if (fInvoker = nil) then fInvoker := fInvokerClass.Create; // Only creates it when really needed

  result := fInvoker;
end;

procedure TROClassFactory.ReleaseInstance(const aClientID: TGUID; var anInstance: IInterface);
begin
  anInstance := nil;
end;

function FinalizeClasses: boolean;
begin
  FreeAndNil(_ClassFactoryList);
  result := True;
end;

initialization
  _ServerClasses := TClassList.Create;
  _ClassFactoryList := nil;
  {$IFNDEF DESIGNTIME}
  AddTerminateProc(FinalizeClasses);
  {$ENDIF DESIGNTIME}
  RegisterExceptionClass(EROSendNoResponse);
finalization
  UnregisterExceptionClass(EROSendNoResponse);
  FreeAndNil(_ServerClasses);
  {$IFDEF DESIGNTIME}
  FinalizeClasses();
  {$ENDIF DESIGNTIME}
end.