unit uROBaseSuperHttpChannel;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Core Components                                   }
{                                                                            }
{ 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, uROClient, uROClientIntf, uROAsync, uROClasses, SyncObjs,
  {$IFDEF RemObjects_UseEncryption} uRoEncryption, {$ENDIF}uROThreadPool;

type
  TDynByteArray = array of byte;
  TROHttpWaitingRequest = class
  private
    fEvent: TROEvent;
    fFreeEvent: Boolean;
    fId: Integer;
    fResultData: TDynByteArray;
    fResultErrorCode: Integer;
  public
    property Id: Integer read fId;
    property Event: TROEvent read fEvent;
    property Resultdata: TDynByteArray read fResultData write fResultData;
    property ResultErrorCode: Integer read fResultErrorCode write fResultErrorCode;

    constructor Create(Id: Integer); overload;
    constructor Create(Id: Integer; Ev: TROEvent); overload;
    destructor Destroy; override;
  end;
  EROSuperHttpChannelException = class(EROException);
  TROBaseSuperHttpChannel = class(TROTransportChannel, IROTransport,
    IROActiveEventChannel, IROMultiThreadAwareChannel,
    IROAsyncTransportChannel, IROActiveAsyncTransportChannel, IROTransportChannelEx)
  private
    fConnectWait: TROEvent;
    fActive, fConnected: Boolean;
    fSessionId, fConnectionId: TGuid;
    fRemoteMaxPackageSize,
    fMaxPackageSize: Integer;
    fWaitingRequest: TThreadList;
    fPackageCounter: Integer;
    fOwnsThreadPool: Boolean;
    fEventThreadPool: TROThreadPool;
    fDispatchLock: TCriticalSection;
    fWaitingThread: TThread;
    fEventReceiver: IROEventReceiver;
    fRequestTimeout: Integer;
    fConnectTimeout: Integer;
    fHttpRequestTimeout: Integer;
    procedure SetActive(const Value: Boolean);
    procedure ProcessEvent(aId: Integer; aData: TDynByteArray);
    procedure SetEventThreadPool(const Value: TROThreadPool);
  protected
    procedure IntDispatch(aRequest: TStream; aResponse: TStream); override;
    procedure IntSetServerLocator(aServerLocator: TROServerLocator); override;
    function CheckStatus(const iMessageID: String): Boolean;
    procedure RetrieveResponse(const iMessageID: String;
      aResponse: TStream);
    procedure BeforeDispatch(aMessage: IROMessage); override;
    procedure RegisterEventReceiver(aReceiver: IROEventReceiver);
    procedure UnregisterEventReceiver(aReceiver: IROEventReceiver);
    function InvokeRequest(aRequest:TStream; iGetResponse:boolean=true):string; overload;
    function InvokeRequest(aRequest:TStream; aGetResponse:boolean=true; aEvent: TROEvent=nil):string; overload;

    procedure CancelRequest(aWaitingThread: Boolean); virtual; abstract;
    procedure DispatchHttpRequest(aWaitingThread: Boolean; aRequest: TDynByteArray; out aResponse: TDynByteArray); virtual; abstract;

  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    property EventThreadPool :TROThreadPool read fEventThreadPool write SetEventThreadPool;
    property ConnectionId: TGUID read fConnectionId write fConnectionId;
    property SessionId: TGuid read fSessionId write fSessionId;
    property Connected: Boolean read fConnected;
    property Active: Boolean read fActive write SetActive;
    property MaxPackageSize: Integer read fMaxPackageSize write fMaxPackageSize default 1024 * 1024;
    property RequestTimeout: Integer read fRequestTimeout write fRequestTimeout default 60000;
    property ConnectTimeout: Integer read fConnectTimeout write fConnectTimeout default 10000;
    property HttpRequestTimeout: Integer read fHttpRequestTimeout write fHttpRequestTimeout default 10000;
  end;
const
  ShHello = 0;
  ShGoodbye = 1;
  ShPackage = 2;
  ShError = 3;
  ShError_InvalidClientId = 0;
  ShError_QueueFull = 1;
  ShError_UnknownOption = 2;
  ShOptions = 4;
  ShAsyncWait = 5;
implementation

uses Math;

type
  TROSuperHttpThread = class(TThread)
  private
    fOwner: TROBaseSuperHttpChannel;
  public
    constructor Create(aOwner: TROBaseSuperHttpChannel);
    procedure Execute; override;
  end;

{ TROHttpWaitingRequest }

constructor TROHttpWaitingRequest.Create(Id: Integer);
begin
  fId := Id;
  fEvent := TROEvent.Create(nil, true, false, '');
  fFreeEvent := true;
end;

constructor TROHttpWaitingRequest.Create(Id: Integer; Ev: TROEvent);
begin
  fEvent := Ev;
  if Fevent = nil then begin
    fEvent := TROEvent.Create(nil, true, false, '');
    fFreeEvent := true;
  end;
  fId := Id;
end;

destructor TROHttpWaitingRequest.Destroy;
begin
  if fFreeEvent then fEvent.Free;
  inherited;
end;

{ TROBaseSuperHttpChannel }

procedure TROBaseSuperHttpChannel.BeforeDispatch(aMessage: IROMessage);
begin
  if not fConnected then begin
    Active := true;
    if (fConnectWait.WaitFor(fConnectTimeout) <> wrSignaled) or not fConnected then
      raise EROSuperHttpChannelException.Create('Timeout connecting');
  end;
  aMessage.ClientID := fSessionId;
  inherited;
end;

constructor TROBaseSuperHttpChannel.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  fMaxPackageSize := 1 * 1024 * 1024;
  fRequestTimeout := 60000;
  fConnectTimeout := 10000;
  fHttpRequestTimeout := 10000;
  fConnectWait := TROEvent.Create(nil, true, false, '');
  fWaitingRequest := TThreadList.Create;
  ThreadSafe := true;
  fDispatchLock := TCriticalSection.Create;
end;

destructor TROBaseSuperHttpChannel.Destroy;
var
  i: Integer;
  lList: TList;
begin
  if fOwnsThreadPool then fEventThreadPool.Free;
  Active := False;
  fConnectWait.Free;
  lList := fWaitingRequest.LockList;
  try
    for i := 0 to lList.Count -1 do begin
      TROHttpWaitingRequest(lList[i]).Free;
    end;
  finally
    fWaitingRequest.UnlockList;
  end;
  fWaitingRequest.Free;
  fDispatchLock.Free;
  inherited;
end;

procedure TROBaseSuperHttpChannel.IntDispatch(aRequest,
  aResponse: TStream);
var
  lRequest, lResponse: TDynByteArray;
  lList:TList;
  lId: Integer;
  lReq: TROHttpWaitingRequest;
begin
  if aRequest.Size > fRemoteMaxPackageSize then raise EROSuperHttpChannelException.Create('Package too large');
  SetLength(lRequest, 16 + 1 + 4 + aRequest.Size);
  aRequest.Position := 0;

  Move(fConnectionId, lRequest[0], 16);
  lRequest[16] := ShPackage;
  aRequest.Read(lRequest[21], aRequest.Size);
  lList := fWaitingRequest.LockList;
  try
    inc(fPackageCounter);
    if fPackageCounter < 0 then fPackageCounter := 1;
    lId := fPackageCounter;
    lReq := TROHttpWaitingRequest.Create(lId);
    lList.Add(lReq);
  finally
    fWaitingRequest.UnlockList;
  end;
  try
    lRequest[17] := lId;
    lRequest[18] := lId shr 8;
    lRequest[19] := lId shr 16;
    lRequest[20] := lId shr 24;
    fDispatchLock.Enter;
    try
      DispatchHttpRequest(false, lRequest, lResponse);
      if Length(lResponse) >= 6 then begin
        if lResponse[0] = shError then begin
          case lResponse[5] of
            ShError_InvalidClientId: raise EROSuperHttpChannelException.Create('Invalid client id');
            ShError_QueueFull: raise EROSuperHttpChannelException.Create('Queue full');
          else
            raise EROSuperHttpChannelException.Create('Unknown error');
          end;
        end;
      end;
    finally
      fDispatchLock.Release;
    end;
    if lReq.Event.WaitFor(fRequestTimeout) <> wrSignaled then
      raise EROSuperHttpChannelException.Create('Timeout');

    if Length(lReq.fResultData) <> 0 then begin
      aResponse.Write(lReq.fResultData[0], length(lReq.fResultData))
    end else begin
      case lReq.fResultErrorCode of
        ShError_InvalidClientId: raise EROSuperHttpChannelException.Create('Invalid client id');
        ShError_QueueFull: raise EROSuperHttpChannelException.Create('Queue full');
      else
        raise EROSuperHttpChannelException.Create('Unknown error');
      end;
    end;
  finally
    lList := fWaitingRequest.LockList;
    lList.Remove(lReq);
    fWaitingRequest.UnlockList;
    lReq.Free;
  end;
end;

procedure TROBaseSuperHttpChannel.IntSetServerLocator(
  aServerLocator: TROServerLocator);
begin

end;

procedure TROBaseSuperHttpChannel.SetActive(const Value: Boolean);
begin
  if fActive = Value then exit;
  fActive := Value;
  if fActive then begin
    fConnectWait.ResetEvent;
    if fWaitingThread <> nil then fWaitingThread.Free;
    fWaitingThread := TROSuperHttpThread.Create(self);
  end else begin
    fWaitingThread.Terminate;
    CancelRequest(true);
    fWaitingThread.Free;
    fwaitingThread := nil;
  end;
end;

procedure TROBaseSuperHttpChannel.SetEventThreadPool(
  const Value: TROThreadPool);
begin
  if fOwnsThreadPool and (fEventThreadPool <> nil) then fEventThreadPool.Free; 
  fEventThreadPool := Value;
  fOwnsThreadPool := false;
end;

procedure TROBaseSuperHttpChannel.RegisterEventReceiver(
  aReceiver: IROEventReceiver);
begin
  fEventReceiver := aReceiver;
end;

procedure TROBaseSuperHttpChannel.UnregisterEventReceiver(
  aReceiver: IROEventReceiver);
begin
  if fEventReceiver = aReceiver then fEventReceiver := nil;
end;


function FindWaitingRequest(aList: TList; aId: Integer): TROHttpWaitingRequest;
var
  i: Integer;
begin
  for i := aList.count -1 downto 0 do begin
    result := TROHttpWaitingRequest(aList[i]);
    if result.fId = aId then exit;
  end;
  result := nil;
end;

function TROBaseSuperHttpChannel.CheckStatus(
  const iMessageID: String): Boolean;
var
  lList: TList;
  wr: TROHttpWaitingRequest;
begin
  lList := fWaitingRequest.LockList;
  try
    wr := FindWaitingRequest(lList, StrToInt(iMessageId));
    if wr = nil then
      result := true
    else
      result := (Length(wr.Resultdata) <> 0) or (wr.ResultErrorCode <> 0);
  finally
    fWaitingRequest.UnlockList;
  end;
end;

procedure TROBaseSuperHttpChannel.RetrieveResponse(
  const iMessageID: String; aResponse: TStream);
var
  lList: TList;
  wr: TROHttpWaitingRequest;
begin
  lList := fWaitingRequest.LockList;
  try
    wr := FindWaitingRequest(lList, StrToInt(iMessageId));
  finally
    fWaitingRequest.UnlockList;
  end;
  if wr = nil then raise EROSuperHttpChannelException.Create('Invalid request id');
  try
    if wr.fEvent.WaitFor(fRequestTimeout) <> wrSignaled then raise EROSuperHttpChannelException.Create('Timeout');
    if Length(wr.fResultData) > 0 then begin
      aResponse.Write(wr.fresultData[0], Length(wr.fresultData));
      aResponse.Position := 0;
    end else begin
      case wr.fResultErrorCode of
        ShError_InvalidClientId: raise EROSuperHttpChannelException.Create('Invalid client id');
        ShError_QueueFull: raise EROSuperHttpChannelException.Create('Queue full');
      else
        raise EROSuperHttpChannelException.Create('Unknown error');
      end;
    end;
  finally
    lList := fWaitingRequest.LockList;
    try
      lList.Remove(wr);
      wr.Free;
    finally
      fWaitingRequest.UnlockList;
    end;
  end;

end;

function TROBaseSuperHttpChannel.InvokeRequest(aRequest: TStream;
  iGetResponse: boolean): string;
begin
  result := InvokeRequest(aRequest, iGetResponse, nil);
end;

function TROBaseSuperHttpChannel.InvokeRequest(aRequest: TStream;
  aGetResponse: boolean; aEvent: TROEvent): string;
var
  lRequest, lResponse: TDynByteArray;
  lList:TList;
  lId: Integer;
  lReq: TROHttpWaitingRequest;
begin
  if aRequest.Size > fRemoteMaxPackageSize then raise EROSuperHttpChannelException.Create('Package too large');
  SetLength(lRequest, 16 + 1 + 4 + aRequest.Size);
  aRequest.Position := 0;

  Move(fConnectionId, lRequest[0], 16);
  lRequest[16] := ShPackage;
  aRequest.Read(lRequest[21], aRequest.Size);
  lList := fWaitingRequest.LockList;
  try
    inc(fPackageCounter);
    if fPackageCounter < 0 then fPackageCounter := 1;
    lId := fPackageCounter;
    if aGetResponse then begin
      lReq := TROHttpWaitingRequest.Create(lId);
      lList.Add(lReq);
    end else
      lReq := nil;
  finally
    fWaitingRequest.UnlockList;
  end;
  try
    lRequest[17] := lId;
    lRequest[18] := lId shr 8;
    lRequest[19] := lId shr 16;
    lRequest[20] := lId shr 24;
    fDispatchLock.Enter;
    try
      DispatchHttpRequest(false, lRequest, lResponse);
      if Length(lResponse) >= 6 then begin
        if lResponse[0] = shError then begin
          case lResponse[5] of
            ShError_InvalidClientId: raise EROSuperHttpChannelException.Create('Invalid client id');
            ShError_QueueFull: raise EROSuperHttpChannelException.Create('Queue full');
          else
            raise EROSuperHttpChannelException.Create('Unknown error');
          end;
        end;
      end;
    finally
      fDispatchLock.Release;
    end;
    result := inttostr(lId);
  except
    lList := fWaitingRequest.LockList;
    lList.Remove(lReq);
    fWaitingRequest.UnlockList;
    lReq.Free;
    raise;
  end;
end;

type
  TROSuperEventCallback = class(TInterfacedObject, IROThreadPoolCallback)
  private
    fData: TDynByteArray;
    fOwner: TROBaseSuperHttpChannel;
  public
    procedure Callback(Caller: TROThreadPool; aThread: TThread);
  end;

procedure TROBaseSuperHttpChannel.ProcessEvent(aId: Integer;
  aData: TDynByteArray);
var
  lCb: TROSuperEventCallback;
begin
  lCb := TROSuperEventCallback.Create;
  lCb.fOwner := self;
  lCb.fData := aData;
  fEventThreadPool.QueueItem(lCb);
end;

{ TROSuperHttpThread }

constructor TROSuperHttpThread.Create(aOwner: TROBaseSuperHttpChannel);
begin
  inherited Create(true);
  fOwner := aOwner;
  Resume;
end;

procedure TROSuperHttpThread.Execute;
var
  lRequest,
  lTmpData,
  lResponse: TDynByteArray;
  lList: TList;
  lPackageId: Integer;
  wr: TROHttpWaitingRequest;
begin
  try
    if IsEqualGuid(fOwner.fConnectionId, Emptyguid) then fOwner.fConnectionId := NewGuid;
    SetLength(lRequest, 16 + 1 +8 + 4 + 16);
    Move(fOwner.fConnectionId, lRequest[0], 16);
    lRequest[16] := shHello;
    lRequest[17] := ord('R');
    lRequest[18] := ord('O');
    lRequest[19] := ord('S');
    lRequest[20] := ord('H');
    lRequest[21] := ord('1');
    lRequest[22] := ord('0');
    lRequest[23] := ord('0');
    lRequest[24] := ord('0');
    lRequest[25] := fOwner.fMaxPackageSize;
    lRequest[26] := fOwner.fMaxPackageSize shr 8;
    lRequest[27] := fOwner.fMaxPackageSize shr 16;
    lRequest[28] := fOwner.fMaxPackageSize shr 16;
    Move(fOwner.fSessionId, lRequest[29], 16);
    fOwner.fDispatchLock.Enter;
    try
      fOwner.DispatchHttpRequest(false, lRequest, lResponse);
    finally
      fOwner.fDispatchLock.Leave;
    end;
    if Length(lResponse) <> (16 + 8 + 4) then
      raise EROSuperHttpChannelException.Create('Invalid response from server for connection initiation command');

    if (lResponse[0] <> ord('R')) or (lResponse[1] <> ord('O')) or (lResponse[2] <> ord('S')) or (lResponse[3] <> ord('H')) then
      raise EROSuperHttpChannelException.Create('Invalid response from server for connection initiation command');
    fOwner.fRemoteMaxPackageSize := Integer(lResponse[8]) or (Integer(lResponse[9]) shl 8)
     or (Integer(lResponse[10]) shl 16) or (Integer(lResponse[11]) shl 24);
    move(lResponse[12], fOwner.fSessionId, 16);
    fOwner.fConnected := true;
    fOwner.fConnectWait.SetEvent;
    SetLength(lRequest, 17);
    move(fOwner.fConnectionId, lRequest[0], 16);
    lRequest[16] := ShAsyncWait;
    while not Terminated do begin
      try
        fOwner.DispatchHttpRequest(true, lRequest, lResponse);
      except
        continue;
      end;
      if Length(lResponse) <> 0 then begin
        case lResponse[0] of
          ShError: begin
            if Length(lResponse) < 5 then continue;
            lPackageId := Integer(lResponse[1]) or (Integer(lResponse[2]) shl 8)
            or (Integer(lResponse[3]) shl 16) or (Integer(lResponse[4]) shl 24);
            lList := fOwner.fWaitingRequest.LockList;
            try
              wr := FindWaitingRequest(lList, lPackageId);
              if wr <> nil then begin
               wr.fResultErrorCode := lResponse[4];
               wr.fEvent.SetEvent;
              end;
            finally
              fOwner.fWaitingRequest.UnlockList;
            end;
          end;
          shPackage: begin
            if Length(lResponse) < 5 then continue;
            lPackageId := Integer(lResponse[1]) or (Integer(lResponse[2]) shl 8)
            or (Integer(lResponse[3]) shl 16) or (Integer(lResponse[4]) shl 24);
            setLength(lTmpData, Length(lResponse) -5);
            Move(lResponse[5], lTmpData[0], Length(lTmpData));
            if lPackageId < 0 then
              fOwner.ProcessEvent(lPackageId, lTmpData)
            else begin
              lList := fOwner.fWaitingRequest.LockList;
              try
                wr := FindWaitingRequest(lList, lPackageId);
                if wr <> nil then begin
                 wr.fResultData := lTmpData;
                 wr.fEvent.SetEvent;
                end;
              finally
                fOwner.fWaitingRequest.UnlockList;
              end;
            end;
          end;
        end;
      end;
    end;
    lRequest[16] := shGoodbye;
    fOwner.fDispatchLock.Enter;
    try
      fOwner.DispatchHttpRequest(false, lRequest, lResponse);
    finally
      fOwner.fDispatchLock.Leave;
    end;
  except
    // cannot let exceptions escape here
  end;
end;

{ TROSuperEventCallback }

procedure TROSuperEventCallback.Callback(Caller: TROThreadPool;
  aThread: TThread);
var
  lData: TMemoryStream;
begin
  if fOwner.fEventReceiver <> nil then begin
    lData := TMemoryStream.Create;
    try
      lData.Write(fData[0], length(fData));
      lData.Position := 0;
      fOwner.fEventReceiver.Dispatch(lData, aThread);
    finally
       lData.Free;
    end;
  end;
end;

end.