unit uROBinMessage;

{----------------------------------------------------------------------------}
{ 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
  {$IFDEF REMOBJECTS_TRIAL}uROTrial, {$ENDIF}
  Classes, SysUtils, TypInfo,
  uROSerializer, uROClient, uROClientIntf;

type
  TBinMessageSignature = array[0..4] of char;

const
  BinSignature: TBinMessageSignature = 'RO107';
  EncryptedBinSignature: TBinMessageSignature = 'roroc';

  BIN_HEADER_SIZE = $1c;

  { Misc }
  {
    // Header BINARY LAYOUT: $1C bytes
    //
    // Keep in sync with
    //  - Delphi - uROBINMessage.pas
    //  - C#     - BinMessage.cs
    //
    // 52 4f 31 30  = "RO10" basic RO signature for RO 1.0
    // XX YY ZZ --  = XX: subversion (currenly "7")
    //		 YY: option flags: 01 = compressed
    //		 ZZ: message type as defined in uROClientIntf
    //     --: reserved for future use
    // -- -- UU UU  = UU: user data (word)
    // CC CC CC CC    $10 bytes ClientID (guid)
    // CC CC CC CC
    // CC CC CC CC
    // CC CC CC CC
  }

type
  TBinHeaderArray = array[0..BIN_HEADER_SIZE - 1] of byte;
  TBinMessageType = Byte;

type
  TBinHeader = class
  private
    fHeader: TBinHeaderArray;
    function GetCompressed: boolean;
    procedure SetCompressed(const Value: boolean);
    function GetSignatureValid: boolean;
    function GetSignatureIsEncrypted: boolean;
    function GetMessageType: TBinMessageType;
    procedure SetMessageType(const Value: TBinMessageType);
    function GetUserData: Word;
    procedure SetUserData(const Value: Word);
    function GetClientID: TGUID;
    procedure SetClientID(const Value: TGUID);

  public
    constructor CreateFromStream(iStream: TStream);
    constructor Create;
    procedure WriteToStream(iStream: TStream);

    {$IFNDEF DELPHI10UP}property Header: TBinHeaderArray read fHeader;{$ENDIF}
    property Compressed: boolean read GetCompressed write SetCompressed;
    property SignatureValid: boolean read GetSignatureValid;
    property SignatureIsEncrypted: boolean read GetSignatureIsEncrypted;
    property MessageType: TBinMessageType read GetMessageType write SetMessageType;
    property UserData: Word read GetUserData write SetUserData;    
    property ClientID: TGUID read GetClientID write SetClientID;
  end;

  TROCompressionEvent = procedure(OriginalSize, CompressedSize, CompressionTime: integer) of object;

  { TROBinMessage }

  IROBinMessage = interface(IROMessage)
    ['{255E6B2C-66BC-4BE3-9C29-459D00221F7E}']
    function GetCompressionBufferSize: integer;
    function GetUseCompression: boolean;
    function GetMinSizeForCompression: integer;
    procedure SetMinSizeForCompression(const Value: integer);
    procedure SetCompressionBufferSize(const Value: integer);
    procedure SetUseCompression(const Value: boolean);
    function GetWasCompressed : boolean;

    function GetStream: TStream;

    property UseCompression: boolean read GetUseCompression write SetUseCompression;
    property MinSizeForCompression: integer read GetMinSizeForCompression write SetMinSizeForCompression;
    property CompressionBufferSize: integer read GetCompressionBufferSize write SetCompressionBufferSize;
    property Stream: TStream read GetStream;
    property WasCompressed : boolean read GetWasCompressed;
  end;

  TROBinMessage = class(TROMessage, IROBinMessage, IROStreamAccess)
  private
    fStream: TStream;
    fUseCompression: boolean;
    fDestroyStream: boolean;
    fWasCompressed: boolean;
    fOnCompress: TROCompressionEvent;
    fOnDecompress: TROCompressionEvent;
    fCompressionBufferSize: integer;
    fType: TMessageType;
    fMinSizeForCompression: integer;
    function GetMinSizeForCompression: integer;
    procedure SetMinSizeForCompression(const Value: integer);

    procedure WriteStream(aMessageType: TBinMessageType; Source, Destination: TStream);

    function GetCompressionBufferSize: integer;
    function GetUseCompression: boolean;
    procedure SetCompressionBufferSize(const Value: integer);
    procedure SetUseCompression(const Value: boolean);
    function GetWasCompressed : boolean;

  protected
    { Internals }
    function ReadException: Exception; override;
    procedure WriteException(aStream: TStream; anException: Exception); override;

    function CreateSerializer: TROSerializer; override;

    { IROMessage }
    procedure Initialize(const aTransport: IROTransport; const anInterfaceName, aMessageName: string; aType: TMessageType); override;


    procedure WriteToStream(aStream: TStream); override;
    procedure IntReadFromStream(aStream: TStream; CopyStream: Boolean);

    procedure ReadFromStream(aStream: TStream); overload; override;
    procedure ReadFromStream(aStream: TStream; var aFreeStream: Boolean); overload; override;

    function GetStream: TStream;
    procedure FreeStream; override;
    procedure InitializeExceptionMessage(const aTransport: IROTransport;
      const aLibraryName: String; const anInterfaceName: String;
      const aMessageName: String); override;
  public
    procedure InitObject; override;
    destructor Destroy; override;

    procedure Assign(iSource: TPersistent); override;

    property Stream: TStream read FStream;
    function IsValidMessage(aData: PChar; aLength: Integer): boolean;  override;
  published
    property UseCompression: boolean read GetUseCompression write SetUseCompression default true;
    property MinSizeForCompression: integer read GetMinSizeForCompression write SetMinSizeForCompression default 4096;
    property CompressionBufferSize: integer read GetCompressionBufferSize write SetCompressionBufferSize default 256 * 1024;
    property OnCompress: TROCompressionEvent read fOnCompress write fOnCompress;
    property OnDecompress: TROCompressionEvent read fOnDecompress write fOnDecompress;
  end;

implementation

uses
  {$IFDEF MSWINDOWS}Windows, {$ENDIF MSWINDOWS}
  {$IFDEF DEBUG_REMOBJECTS_BINMESSAGE}eDebugServer, {$ENDIF DEBUG_REMOBJECTS_BINMESSAGE}
  uROStreamSerializer,
  uRORes, uROCompression, uROHTTPTools, uROClasses,
  uROTypes, uROBinaryHelpers, uROZLib;

{ TROBinMessage }

destructor TROBinMessage.Destroy;
begin
  if fDestroyStream then FreeAndNIL(fStream);
  inherited;
end;

function TROBinMessage.CreateSerializer: TROSerializer;
begin
  result := TROStreamSerializer.Create(nil);
end;

procedure TROBinMessage.Initialize(const aTransport: IROTransport; const anInterfaceName, aMessageName: string; aType: TMessageType);
begin
  inherited;

  SetHTTPInfo(aTransport, DataFormatBinary);

  if fDestroyStream then FreeAndNIL(fStream);
  fStream := TMemoryStream.Create;
  fDestroyStream := TRUE;

  (Serializer as TROStreamSerializer).SetStorageRef(fStream); // Very important!

  MessageName := aMessageName;
  InterfaceName := anInterfaceName;
  fType := aType;

  Stream_WriteStringWithLength(fStream, InterfaceName);
  Stream_WriteStringWithLength(fStream, MessageName);
end;

procedure TROBinMessage.IntReadFromStream(aStream: TStream; CopyStream: Boolean);
var //sze : integer;
  //s : string;
  lHeader: TBinHeader;
  lPos: Int64;
  {$IFDEF REMOBJECTS_PERFORMANCE_MEASUREMENT}
  start: Integer;
  PerformanceFrequency,
    PerformanceCounter: Int64;
  {$ENDIF REMOBJECTS_PERFORMANCE_MEASUREMENT}
begin
  inherited;

  {$IFDEF DEBUG_REMOBJECTS_BINMESSAGE}
  DebugServer.EnterMethod('TROBinMessage.ReadFromStream(stream=%x; position:$%x)', [integer(pointer(aStream)), aStream.Position]);
  try
    DebugServer.WriteHexDump('Incoming BIN, start of ReadFromStream: ', aStream);
    //aStream.Seek(0,soBeginning);
    {$ENDIF DEBUG_REMOBJECTS_BINMESSAGE}

    if fDestroyStream then FreeAndNIL(fStream);

    lHeader := TBinHeader.CreateFromStream(aStream);
    try
      fWasCompressed := lHeader.Compressed;
      SetClientID(lHeader.ClientID);

      if lHeader.Compressed then begin
        {$IFDEF REMOBJECTS_PERFORMANCE_MEASUREMENT}
        if not QueryPerformanceFrequency(PerformanceFrequency) then RaiseLastOSError;
        if not QueryPerformanceCounter(PerformanceCounter) then RaiseLastOSError;
        start := GetTickCount();
        {$ENDIF REMOBJECTS_PERFORMANCE_MEASUREMENT}

        fDestroyStream := TRUE;
        fStream := TMemoryStream.Create;

        ZDecompressStream(aStream, fStream);

        {$IFDEF DEBUG_REMOBJECTS_BINMESSAGE}
        DebugServer.WriteHexDump('Decompressed BIN message (sans Header): ', fStream);
        //aStream.Seek(0,soBeginning);
        {$ENDIF DEBUG_REMOBJECTS_BINMESSAGE}

        {$IFDEF REMOBJECTS_PERFORMANCE_MEASUREMENT}
        if not QueryPerformanceCounter(PerformanceCounter) then RaiseLastOSError;
        if Assigned(OnDeCompress) then OnDecompress(fStream.Size, aStream.Size, GetTickCount - start);
        {$ELSE}
        if Assigned(OnDeCompress) then OnDecompress(fStream.Size, aStream.Size, 0);
        {$ENDIF REMOBJECTS_PERFORMANCE_MEASUREMENT}

        fStream.Position := 0;
        // TROTransportChannel.Dispatch always destroys stream if error.
        if (lHeader.MessageType<>MESSAGE_TYPE_EXCEPTION) then
          if not CopyStream then aStream.Free;
      end
      else begin
        if CopyStream then begin
          fStream := TMemoryStream.Create;
          lPos := aStream.Position;
          aStream.position := 0;
          fStream.CopyFrom(aStream, aStream.Size);
          fStream.Position := lPos;
        end
        else
          fStream := aStream;
        fDestroyStream := true;
      end;

      (Serializer as TROStreamSerializer).SetStorageRef(fStream); // Very important!

      case lHeader.MessageType of
        MESSAGE_TYPE_EVENT,
        MESSAGE_TYPE_MESSAGE: begin
            InterfaceName := Stream_ReadStringWithLength(fStream, MAX_ITEM_NAME);
            MessageName := Stream_ReadStringWithLength(fStream, MAX_ITEM_NAME);
          end;
        MESSAGE_TYPE_EXCEPTION: begin
            ProcessException;
          end;
      else // Do what?
      end;

    finally
      FreeAndNil(lHeader);
    end;

  {$IFDEF DEBUG_REMOBJECTS_BINMESSAGE}
  finally
    DebugServer.ExitMethod('TROBinMessage.ReadFromStream(stream=%x; position:$%x)', [integer(pointer(fStream)), fStream.Position]);
  end;
  {$ENDIF DEBUG_REMOBJECTS_BINMESSAGE}

end;

procedure TROBinMessage.WriteToStream(aStream: TStream);
begin
  if fType = mtEvent then
    WriteStream(MESSAGE_TYPE_EVENT, fStream, aStream)
  else
    WriteStream(MESSAGE_TYPE_MESSAGE, fStream, aStream);

  inherited;
end;

function TROBinMessage.ReadException: Exception;
var
  lExceptionName, lMessage: string;
begin
  // At this point the stream is already at position 1
  lExceptionName := Stream_ReadStringWithLength(fStream, MAX_ITEM_NAME);
  lMessage := Stream_ReadStringWithLength(fStream, MAX_EXCEPTION_TEXT);

  result := CreateException(lExceptionName, lMessage);

  // Reads the other fields which have been properly serialized
  if result.InheritsFrom(EROException) then
    Serializer.Read(name_Exception, result.ClassType.ClassInfo, result);
    
  fDestroyStream:=False; // we destroy stream in TROTransportChannel.Dispatch
end;

procedure TROBinMessage.WriteException(aStream: TStream; anException: Exception);
var typinfo : PTypeInfo;
begin
  if fDestroyStream then FreeAndNIL(fStream);
  fStream := TMemoryStream.Create;
  fDestroyStream := TRUE;

  Stream_WriteStringWithLength(fStream, anException.ClassName);
  Stream_WriteStringWithLength(fStream, anException.Message);

  if (anException is EROException) then begin
    with TROStreamSerializer.Create(fStream) do try
      typinfo := anException.ClassInfo;
      Write(name_Exception, typinfo, anException);
    finally
      Free;
    end;
  end;

  WriteStream(MESSAGE_TYPE_EXCEPTION, fStream, aStream);
  inherited;
end;

procedure TROBinMessage.WriteStream(aMessageType: TBinMessageType; Source, Destination: TStream);
var
  lHeader: TBinHeader;
  {$IFDEF REMOBJECTS_PERFORMANCE_MEASUREMENT}
  start: Integer;
  PerformanceFrequency,
    PerformanceCounter: Int64;
  {$ENDIF REMOBJECTS_PERFORMANCE_MEASUREMENT}
begin
  {$IFDEF DEBUG_REMOBJECTS_BINMESSAGE}
  DebugServer.EnterMethod('TROBinMessage.WriteStream()');
  try
    {$ENDIF DEBUG_REMOBJECTS_BINMESSAGE}

    // Writes the header
    lHeader := TBinHeader.Create();
    try
      lHeader.Compressed := UseCompression and (Source.Size >= MinSizeForCompression);
      lHeader.MessageType := aMessageType;
      lHeader.ClientID := GetClientID;
      lHeader.WriteToStream(Destination);
    finally
      FreeAndNil(lHeader);
    end;

    // Writes the data
    Source.Position := 0;
    if UseCompression and (Source.Size >= MinSizeForCompression) then begin

      {$IFDEF DEBUG_REMOBJECTS_BINMESSAGE}
      DebugServer.WriteHexDump('Uncompressed BIN: ', Source);
      {$ENDIF DEBUG_REMOBJECTS_BINMESSAGE}

      {$IFDEF REMOBJECTS_PERFORMANCE_MEASUREMENT}
      if not QueryPerformanceFrequency(PerformanceFrequency) then
        RaiseLastOSError;
      if not QueryPerformanceCounter(PerformanceCounter) then
        RaiseLastOSError;
      start := GetTickCount { + Frac(PerformanceCounter / PerformanceFrequency * MSecsPerSec)};
      {$ENDIF REMOBJECTS_PERFORMANCE_MEASUREMENT}

      ZCompressStream(Source, Destination);

      {$IFDEF REMOBJECTS_PERFORMANCE_MEASUREMENT}
      if not QueryPerformanceCounter(PerformanceCounter) then RaiseLastOSError;
      if Assigned(OnCompress) then OnCompress(Source.Size, Destination.Size, GetTickCount - start);
      {$ELSE }
      if Assigned(OnCompress) then OnCompress(Source.Size, Destination.Size, 0);
      {$ENDIF REMOBJECTS_PERFORMANCE_MEASUREMENT}
    end
    else begin
      TMemoryStream(Source).SaveToStream(Destination);
      {ToDo -cOptimization/RO4: The infrastructure could re rearranged so that the message
        could be written to the final stream right away. This would require significant
        changes to proxy and invoker code, among others, so we'll defer to RO4. mh. }
    end;

    {$IFDEF DEBUG_REMOBJECTS_BINMESSAGE}
    DebugServer.WriteHexDump('Outgoing BIN: ', Destination);
  finally
    DebugServer.ExitMethod('TROBinMessage.WriteStream()');
  end;
  //Destination.Seek(0,soBeginning);
  {$ENDIF DEBUG_REMOBJECTS_BINMESSAGE}

end;

procedure TROBinMessage.InitObject;
begin
  inherited;
  fUseCompression := true;
  fCompressionBufferSize := 256 * 1024;
  fMinSizeForCompression := 4096;
end;

procedure TROBinMessage.Assign(iSource: TPersistent);
var
  lSource: TROBinMessage;
begin
  inherited;
  if Assigned(iSource) then begin
    if not (iSource is TROBinMessage) then RaiseError('Cannot Assign a %s t a %s', [ClassName, iSource.ClassName]);
    lSource := TROBinMessage(iSource);
    self.UseCompression := lSource.UseCompression;
    self.MinSizeForCompression := lSource.MinSizeForCompression;
    self.CompressionBufferSize := lSource.CompressionBufferSize;
    self.OnCompress := lSource.OnCompress;
    self.OnDecompress := lSource.OnDecompress;
    //ToDO -c2.0 -omh: clone the stream to, if one is assigned;
  end;
end;

function TROBinMessage.GetCompressionBufferSize: integer;
begin
  result := fCompressionBufferSize;
end;

function TROBinMessage.GetMinSizeForCompression: integer;
begin
  result :=  fMinSizeForCompression;
end;

function TROBinMessage.GetUseCompression: boolean;
begin
  result := fUseCompression;
end;

procedure TROBinMessage.SetCompressionBufferSize(const Value: integer);
begin
  fCompressionBufferSize := Value;
end;

procedure TROBinMessage.SetMinSizeForCompression(const Value: integer);
begin
  fMinSizeForCompression := Value;
end;

procedure TROBinMessage.SetUseCompression(const Value: boolean);
begin
  fUseCompression := Value;
end;

function TROBinMessage.GetStream: TStream;
begin
  result := fStream;
end;

function TROBinMessage.GetWasCompressed: boolean;
begin
  result := fWasCompressed;
end;

procedure TROBinMessage.ReadFromStream(aStream: TStream);
begin
  inherited;
  IntReadFromStream(aStream, true);
end;

procedure TROBinMessage.ReadFromStream(aStream: TStream;
  var aFreeStream: Boolean);
begin
  inherited ReadFromStream(aStream);
  aFreeStream := False; // set to false BEFORE the call; as the following might raise exceptions
  IntReadFromStream(aStream, false);
end;

procedure TROBinMessage.FreeStream;
begin
  inherited;
  if fDestroyStream then FreeAndNil(FStream);
end;

procedure TROBinMessage.InitializeExceptionMessage(
  const aTransport: IROTransport; const aLibraryName, anInterfaceName,
  aMessageName: String);
begin
  inherited;
  SetHTTPInfo(aTransport, DataFormatBinary);
end;

function TROBinMessage.IsValidMessage(aData: PChar; aLength: Integer): boolean;
begin
  Result := (aLength >= Sizeof(TBinMessageSignature)) and
   ((StrLComp(aData, Pchar(@BinSignature),SizeOf(TBinMessageSignature))=0) or
   (StrLComp(aData, Pchar(@EncryptedBinSignature),SizeOf(TBinMessageSignature))=0));
end;

{ TBinHeader }

const
  OFFSET_MESSAGE_FLAGS = $05; { offset of Flags field in header }
  OFFSET_MESSAGE_TYPE = $06; { offset of Type field in header }
  OFFSET_USER_DATA = $0a; { offset of UserData field in header }
  OFFSET_CLIENTID = $0c; { offset of ClientID GUID }

  BINMESSAGE_FLAG_COMPRESSED = $01;

constructor TBinHeader.Create;
begin
  inherited Create();

  fHeader[0] := Ord(BINSignature[0]);
  fHeader[1] := Ord(BINSignature[1]);
  fHeader[2] := Ord(BINSignature[2]);
  fHeader[3] := Ord(BINSignature[3]);
  fHeader[4] := Ord(BINSignature[4]);
end;

constructor TBinHeader.CreateFromStream(iStream: TStream);
begin
  inherited Create();
  iStream.ReadBuffer(fHeader, SizeOf(fHeader));
  if not SignatureValid then begin
    if SignatureIsEncrypted then
      RaiseInvalidStreamError(err_InvalidHeaderEncrypted, [], iStream);
    RaiseInvalidStreamError(err_InvalidHeader, [], iStream);
  end;
end;

function TBinHeader.GetMessageType: TBinMessageType;
begin
  result := TBinMessageType(fHeader[OFFSET_MESSAGE_TYPE]);
end;

procedure TBinHeader.SetMessageType(const Value: TBinMessageType);
begin
  fHeader[OFFSET_MESSAGE_TYPE] := byte(Value);
end;

function TBinHeader.GetSignatureIsEncrypted: boolean;
begin
  result := (fHeader[0] = ord(EncryptedBinSignature[0])) and
    (fHeader[1] = ord(EncryptedBinSignature[1])) and
    (fHeader[2] = ord(EncryptedBinSignature[2])) and
    (fHeader[3] = ord(EncryptedBinSignature[3])) and
    (fHeader[4] = ord(EncryptedBinSignature[4]));
end;

function TBinHeader.GetSignatureValid: boolean;
begin
  result := (fHeader[0] = ord(BINSignature[0])) and
    (fHeader[1] = ord(BINSignature[1])) and
    (fHeader[2] = ord(BINSignature[2])) and
    (fHeader[3] = ord(BINSignature[3])) and
    (fHeader[4] = ord(BINSignature[4]));
end;

function TBinHeader.GetCompressed: boolean;
begin
  result := fHeader[OFFSET_MESSAGE_FLAGS] and BINMESSAGE_FLAG_COMPRESSED = BINMESSAGE_FLAG_COMPRESSED;
end;

procedure TBinHeader.SetCompressed(const Value: boolean);
begin
  if Value then
    fHeader[OFFSET_MESSAGE_FLAGS] := fHeader[OFFSET_MESSAGE_FLAGS] or BINMESSAGE_FLAG_COMPRESSED
  else
    fHeader[OFFSET_MESSAGE_FLAGS] := fHeader[OFFSET_MESSAGE_FLAGS] and not BINMESSAGE_FLAG_COMPRESSED;
end;

procedure TBinHeader.WriteToStream(iStream: TStream);
begin
  iStream.Write(fHeader, SizeOf(fHeader));
end;

function TBinHeader.GetUserData: Word;
begin
  result := Word((@fHeader[OFFSET_USER_DATA])^);
end;

procedure TBinHeader.SetUserData(const Value: Word);
begin
  Word((@fHeader[OFFSET_USER_DATA])^) := Value;
end;

function TBinHeader.GetClientID: TGUID;
begin
  Move(fHeader[OFFSET_CLIENTID], result, SizeOf(TGUID));
end;

procedure TBinHeader.SetClientID(const Value: TGUID);
begin
  Move(Value, fHeader[OFFSET_CLIENTID], SizeOf(TGUID));
end;

initialization
  RegisterMessageClass(TROBinMessage);

end.