unit uROIndyUDPChannel;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Indy Components                                   }
{                                                                            }
{ compiler: Delphi 5 and up, Kylix 2 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Provided by Nico Schoemaker (nico.schoemaker@teamro.remobjects.com         }
{                                                                            }
{ 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,
     IdUDPClient,
     uROClient, uROClientIntf, uROAsyncResponseStorage, uROAsync, uROThread,
     uROClasses;

type

  TROIndyUDPChannel = class;

  TROUDPResponseThread = class(TROThread)
  private
    FChannel: TROIndyUDPChannel;
    FCriticalSection: TCriticalSection;
    FReqUID: String;
  protected
    FRetrys: Integer;
    FRespReceived: Boolean;
    procedure DoTimeOut;
    procedure DoEnd;
    procedure Execute;override;
  public
    property RequestUID: String read FReqUID;
    property ReceivedResponse: Boolean read FRespReceived;
    property Channel: TROIndyUDPChannel read FChannel;
    property CriticalSection: TCriticalSection read FCriticalSection;

    constructor Create(const aName: string; aChannel: TROIndyUDPChannel; aRequestUID: String);
  end;

  TROUDPResponseThreadClass = class of TROUDPResponseThread;

  TROAsyncTimeOutEvent = procedure (aRequistUID: String) of object;

  TROIndyUDPChannel = class(TROTransportChannel, IROTransport, IROTCPTransport,
                            IROAsyncTransportChannel, IROAsyncResponseStorage)
  private
    fIndyClient: TIdUDPClient;
    FRespStorage: TROSimpleAsyncResponseStorage;
    FReqStorage: TROSimpleAsyncResponseStorage;
    FRespBuffer: TStringList;
    FRetrys: Integer;
    FAsyncTimeOut: Integer;
    FOnAsyncResponseTimeOut: TROAsyncTimeOutEvent;
    FRunningThread: TROUDPResponseThread;
    function GetHost: string;
    function GetPort: integer;
    procedure SetHost(const Value: string);
    procedure SetPort(const Value: integer);
  protected
    FCriticalSection: TCriticalSection;
    FIDSize: Integer;

    { IROTransport }
    function GetTransportObject : TObject; override;

    { IROTCPTransport }
    function GetClientAddress : string;

    { IROAsyncTransportChannel }
    function  InvokeRequest(aRequest:TStream; iGetResponse:boolean=true):string;virtual;
    procedure RetrieveResponse(const iMessageID:string; aResponse:TStream);

    procedure DoEndOfThread(Sender: TROUDPResponseThread);virtual;
    procedure DoOnTerminateThread(Sender: TObject);virtual;
    procedure DoAsyncThreadTimeOut(ReqUID: String);virtual;

    procedure IntDispatch(aRequest, aResponse : TStream); override;
    procedure IntSetServerLocator(aServerLocator: TROServerLocator); override;
    procedure SendReq(aRequest: TStream;UID: String;AddToStorage: Boolean=true);virtual;
    function  GetResponseThreadClass: TROUDPResponseThreadClass;virtual;

    // Setters
    procedure SetRetrys(const Value: Integer);
    procedure SetAsyncTimeOut(const Value: Integer);
    procedure SetOnAsyncResponseTimeOut(const Value: TROAsyncTimeOutEvent);

    // Helpers
    procedure CleanUpStorages;virtual;
    function  GetNewMesgID: String;virtual;
    function  StripID(var aResponse: String): String;
    procedure CopyStream(aSource,aTarget: TStream);
    function  CreateUDPClient : TIdUDPClient; virtual;
    procedure AddRequestToStorage(aRequest: TStream;aRequestID: String);
  public
    property  ResponseStorage: TROSimpleAsyncResponseStorage read FRespStorage {$IFNDEF FPC} implements IROAsyncResponseStorage {$ENDIF};
    {$IFDEF FPC} // implements does not work in FPC
    procedure AddResp(aResp: TROResponseItem);
    procedure RemoveResp(aResp: TROResponseItem);
    procedure RemoveRespByUID(aUID: String);
    procedure DeleteResp(Index: Integer);
    function  GetResp(Index: Integer): TROResponseItem;
    function  GetRespByUID(aUID: String): TROResponseItem; deprecated;
    function  GetResponseByUID(aUID: String): TROResponseItem;
    function  IndexOfResp(aResp: TROResponseItem): Integer;
    function  CountOfResp: Integer;
    procedure ClearStorage;

    property  ResponseItem[Index: Integer]: TROResponseItem read GetResp;
    {$ENDIF}

    property  RequestStorage: TROSimpleAsyncResponseStorage read FReqStorage;
    function  ReceiveResp(aTimeOut: Integer): Boolean;virtual;
    function  CheckStatus(const iMessageID:string):boolean;

    constructor Create(AOwner: TComponent);override;
    Destructor Destroy;override;
  published
    property AsyncTimeOut: Integer read FAsyncTimeOut write SetAsyncTimeOut default 1000;
    property OnAsyncResponseTimeOut: TROAsyncTimeOutEvent read FOnAsyncResponseTimeOut write SetOnAsyncResponseTimeOut;
    property Retrys: Integer read FRetrys write SetRetrys;
    property IndyClient : TIdUDPClient read fIndyClient;
    property Port : integer read GetPort write SetPort;
    property Host : string read GetHost write SetHost;
  published
    property SynchronizedProbing;
    property OnSendStream;
    property OnReceiveStream;
    property ServerLocators;
    property DispatchOptions;
    property OnServerLocatorAssignment;
    property ProbeServers;
    property ProbeFrequency;
    property OnBeforeProbingServers;
    property OnAfterProbingServers;
    property OnBeforeProbingServer;
    property OnAfterProbingServer;
    property OnLoginNeeded;
  end;

implementation

uses IdUDPBase,IdGlobal;

const C_CLRBUFFER_TO = 50; // TimeOut reading the buffer for ClearRecvBuffer
      C_READTIMEOUT = 'Time out reading server response %s.';
      C_NORESPONSE  = 'Response %s is not available yet.';
      C_EADDREQUEST = 'Parameters of AddRequestToStorage not Assigned';

function  Strm_StreamToStr(aStream: TStream): String;
var OldPos: Integer;
begin
  result := '';
  if not(Assigned(aStream)) then
    Exit;

  OldPos := aStream.Position;
  aStream.Position := 0;

  SetLength(result, aStream.Size);
  if (aStream.Size>0)
    then aStream.Read(result[1], aStream.Size);

  aStream.Position := OldPos;
end;

//------------------------------------------------------------------------------
                                 { TROIndyUDPChannel }
//------------------------------------------------------------------------------

constructor TROIndyUDPChannel.Create(AOwner: TComponent);
begin
  inherited;
  FCriticalSection := TCriticalSection.Create();
  FIndyClient := CreateUDPClient;
  FRespBuffer := TStringList.Create;
  FRespStorage := TROSimpleAsyncResponseStorage.Create(Self);
  FReqStorage := TROSimpleAsyncResponseStorage.Create(Self);

  FRetrys := 5;
  FAsyncTimeOut := 1000;

  // In case the result of GetNewMesgID change's in the future
  FIDSize := Length(GetNewMesgID);

  {$IFDEF DELPHI6UP}
  fIndyClient.SetSubComponent(TRUE);
  {$ENDIF}
end;

destructor TROIndyUDPChannel.Destroy;
begin
  FreeAndNil(FCriticalSection);
  FreeAndNil(FRespBuffer);

  FreeAndNil(FRespStorage);
  FreeAndNil(FReqStorage);

  inherited;
end;

procedure TROIndyUDPChannel.CopyStream(aSource, aTarget: TStream);
var lMs: TMemoryStream;
    lPos: Integer;
begin
  if (not(Assigned(aSource))) or (not(Assigned(aTarget))) then
    Exit;

  lPos := aSource.Position;

  try
    if aTarget is TMemoryStream then
    begin
      TMemoryStream(aTarget).LoadFromStream(aSource);
    end else
    begin
      lMs := TMemoryStream.Create;
      try
        lMs.LoadFromStream(aSource);
        lMs.Position := 0;
        lMs.SaveToStream(aTarget);
      finally
        lMs.Free;
      end;
    end;
  finally
    aSource.Position := lPos;
  end;
end;

function TROIndyUDPChannel.CreateUDPClient: TIdUDPClient;
begin
  result := TIdUDPClient.Create(Self);
  result.Port := 8090;
  result.Name := 'InternalIndyClient';
end;


function TROIndyUDPChannel.GetClientAddress: string;
begin
  result := fIndyClient.Host;
end;

function TROIndyUDPChannel.GetTransportObject: TObject;
begin
  result := Self;
end;

{-----------------------------------------------------------------------------
  Procedure: TROIndyUDPChannel.IntDispatch
  Author:    Nico
  Date:      22-apr-2003
  Arguments: aRequest, aResponse: TStream
  Result:    None
  Called by the framework to send and receive a request/response
  - Send's the request and add's it to the Request storage
  - Recieive's the response and add's it to the Response storage
  - Passes the response to aResponse

-----------------------------------------------------------------------------}
procedure TROIndyUDPChannel.IntDispatch(aRequest, aResponse: TStream);
var lResp: TStream;
    lRetry: Integer;
    lUID: String;
begin
  lRetry := 0;

  try
    lUID := GetNewMesgID;
    lResp := nil;
    SendReq(aRequest,lUID);
    repeat
      if ReceiveResp(IndyClient.ReceiveTimeout) then
      begin
        if FRespStorage.GetRespByUID(lUID) <> nil then
          lResp := FRespStorage.GetRespByUID(lUID).Response;
      end;
      inc(lRetry);
    until (lRetry > Retrys) or (lResp <> nil);

    if lRetry > Retrys then
      raise Exception.Create(Format(C_READTIMEOUT,[lUID]));

    CopyStream(lResp,aResponse);
    aResponse.Position := 0;
    FRespStorage.RemoveRespByUID(lUID);

  finally
    FReqStorage.RemoveRespByUID(lUID);
    CleanUpStorages;
  end;
end;

{-----------------------------------------------------------------------------
  Procedure: TROIndyUDPChannel.AddRequestToStorage
  Author:    Nico
  Date:      22-apr-2003
  Arguments: aRequest: TStream;aRequesID: String
  Result:    None
  Adds a request item to the RequestStorage
-----------------------------------------------------------------------------}
procedure TROIndyUDPChannel.AddRequestToStorage(aRequest: TStream;aRequestID: String);
var lMs: TMemoryStream;
    lReqItm: TROResponseItem;
begin
  if (not(Assigned(aRequest))) or (aRequestID = '') then
    raise Exception.Create(C_EADDREQUEST);

 FCriticalSection.Enter;
 try
   lMS := TMemoryStream.Create;
   CopyStream(aRequest,lMs);
   lReqItm := TROResponseItem.Create(lMS,aRequestID);
   FReqStorage.AddResp(lReqItm);
 finally
   FCriticalSection.Leave;
 end;
end;

{-----------------------------------------------------------------------------
  Procedure: TROIndyUDPChannel.ReceiveResp
  Author:    Nico
  Date:      22-apr-2003
  Arguments: None
  Result:    Boolean
  Recieves a single response and saves it in the ResponseStorage.
-----------------------------------------------------------------------------}
function TROIndyUDPChannel.ReceiveResp(aTimeOut: Integer): Boolean;
var lBuf: String;
    lID: String;
    lResItm: TROResponseItem;
    lResp: TStringStream;
    lIP: String;
{$IFDEF RemObjects_INDY10}
    lPort: TIDPort;
{$ELSE}
    lPort: Integer;
{$ENDIF}
begin
  FCriticalSection.Enter;
  try
    result := False;
    lBuf := IndyClient.ReceiveString(lIP,lPort,aTimeOut);
    if lBuf <> '' then
    begin
      lID := StripID(lBuf);
      lResp := TStringStream.Create(lBuf);
      lResItm := TROResponseItem.Create(lResp,lID);
      lResItm.IP := lIP;
      lResItm.Port := lPort;
      FRespStorage.AddResp(lResItm);
      result := True;
    end;
  finally
    FCriticalSection.Leave;
  end;
end;

procedure TROIndyUDPChannel.SendReq(aRequest: TStream;UID: String;AddToStorage: Boolean=true);
var lReq: String;
begin
  lReq := Strm_StreamToStr(aRequest);
  // Sends the Message identifier in front of the actual message
  IndyClient.Send(UID+lReq);
  if AddToStorage then
    AddRequestToStorage(aRequest,UID);
end;

procedure TROIndyUDPChannel.SetRetrys(const Value: Integer);
begin
  FRetrys := Value;
end;

function TROIndyUDPChannel.GetNewMesgID: String;
begin
  result := NewGuidAsString;
end;

function TROIndyUDPChannel.GetResponseThreadClass: TROUDPResponseThreadClass;
begin
  result := TROUDPResponseThread;
end;

{-----------------------------------------------------------------------------
  Procedure: TROIndyUDPChannel.StripIdentifier
  Author:    Nico
  Date:      18-apr-2003
  Arguments: var aResponse: String
  Result:    String
  Strips the leading Identifier from the given response string and returns it.
-----------------------------------------------------------------------------}
function TROIndyUDPChannel.StripID(var aResponse: String): String;
begin
  if Length(aResponse) < FIDSize then
    raise EROException.Create('Invalid UDP Packet received.');
  result := Copy(aResponse,1,FIDSize);
  Delete(aResponse,1,FIDSize);
end;


{-----------------------------------------------------------------------------
  Procedure: TROIndyUDPChannel.CleanUpStorages
  Author:    Nico
  Date:      22-apr-2003
  Arguments: None
  Result:    None
  Cleans up the Request and Response storages.
  Any response without a request will be removed.
-----------------------------------------------------------------------------}
procedure TROIndyUDPChannel.CleanUpStorages;
var i: Integer;
    lRespUID: String;
    lReqItm: TROResponseItem;
begin
  FCriticalSection.Enter;
  try
    // Remove respones that don't have a request present in the request-storage
    for i := FRespStorage.CountOfResp-1 downto 0 do
    begin
      lRespUID := FRespStorage.ResponseItem[i].UID;
      lReqItm  := FReqStorage.GetRespByUID(lRespUID);
      if lReqItm = nil then
        FRespStorage.DeleteResp(i);
    end;
  finally
    FCriticalSection.Leave;
  end;
end;

function TROIndyUDPChannel.CheckStatus(const iMessageID: string): boolean;
begin
  result := FRespStorage.GetRespByUID(iMessageID) <> nil;
end;

function TROIndyUDPChannel.InvokeRequest(aRequest: TStream; iGetResponse: boolean): string;
var lRT: TROUDPResponseThread;
    lName: String;
begin
  try
    FCriticalSection.Enter;
    try
      result := '';
      if FRunningThread <> nil then
        raise EROChannelBusy.Create('Channel is busy.');

      if not(Assigned(aRequest)) then
        Exit;

      result := GetNewMesgID;

      if iGetResponse then
      begin
        SendReq(aRequest,result);
        lName := GetResponseThreadClass.ClassName+' for reading of response %s';
        lRT := GetResponseThreadClass.Create(Format(lName,[result]),Self,result);
        lRT.OnTerminate := DoOnTerminateThread;
        FRunningThread := lRT;
        lRT.Resume;
      end else
        SendReq(aRequest,result,False);

    finally
      FCriticalSection.Leave;
    end;
  finally
    aRequest.Free();
  end;
end;

procedure TROIndyUDPChannel.RetrieveResponse(const iMessageID: string;aResponse: TStream);
var lResItm: TROResponseItem;
begin
  FCriticalSection.Enter;
  try
    if not(Assigned(aResponse)) then
      Exit;

    if CheckStatus(iMessageID) then begin
      lResItm := FRespStorage.GetRespByUID(iMessageID);
      CopyStream(lResItm.Response,aResponse);
      // Remove the response and request from the storage's
      //FReqStorage.RemoveRespByUID(lResItm.UID);
      FRespStorage.RemoveResp(lResItm);
    end
    else begin
      raise EROAsyncNoAnswerYet.Create(Format(C_NORESPONSE,[iMessageID]));
    end;
  finally
    FCriticalSection.Leave;
  end;
end;

procedure TROIndyUDPChannel.DoEndOfThread(Sender: TROUDPResponseThread);
begin
  CleanUpStorages;
end;

procedure TROIndyUDPChannel.DoOnTerminateThread(Sender: TObject);
begin
  // Runs in the Main thread
  FRunningThread := nil;
end;

procedure TROIndyUDPChannel.DoAsyncThreadTimeOut(ReqUID: String);
begin
  if Assigned(FOnAsyncResponseTimeOut) then
    FOnAsyncResponseTimeOut(ReqUID);
end;

procedure TROIndyUDPChannel.SetOnAsyncResponseTimeOut(const Value: TROAsyncTimeOutEvent);
begin
  FOnAsyncResponseTimeOut := Value;
end;

procedure TROIndyUDPChannel.SetAsyncTimeOut(const Value: Integer);
begin
  FAsyncTimeOut := Value;
  if FAsyncTimeOut < 0 then
    FAsyncTimeOut := 0;
end;

{ TROUDPResponseThread }
constructor TROUDPResponseThread.Create(const aName: string; aChannel: TROIndyUDPChannel; aRequestUID: String);
begin
  inherited Create(True,aName);
  FreeOnTerminate := true;
  FRespReceived := False;
  FChannel := aChannel;
  FReqUID := aRequestUID;
  FRetrys := aChannel.Retrys;
  FCriticalSection := FChannel.FCriticalSection;
end;

procedure TROUDPResponseThread.Execute;
begin
  inherited;

  repeat
    FChannel.ReceiveResp(FChannel.AsyncTimeOut);
    Dec(FRetrys);
  until (FRetrys < 1) or (FChannel.CheckStatus(FReqUID));

  FRespReceived :=  FRetrys > 0;

  if not FRespReceived
  then Synchronize(DoTimeOut)
  else Synchronize(DoEnd);

end;

procedure TROUDPResponseThread.DoTimeOut;
begin
  FChannel.DoAsyncThreadTimeOut(FReqUID);
end;

procedure TROUDPResponseThread.DoEnd;
begin
  FChannel.DoEndOfThread(Self);
end;


function TROIndyUDPChannel.GetHost: string;
begin
  result := IndyClient.Host
end;

function TROIndyUDPChannel.GetPort: integer;
begin
  result := IndyClient.Port
end;

procedure TROIndyUDPChannel.SetHost(const Value: string);
begin
  IndyClient.Host := Value
end;

procedure TROIndyUDPChannel.SetPort(const Value: integer);
begin
  IndyClient.Port := Value
end;

procedure TROIndyUDPChannel.IntSetServerLocator(
  aServerLocator: TROServerLocator);
begin
  Host := aServerLocator.Host;
  Port := aServerLocator.Port;
end;

{$IFDEF FPC}
procedure TROIndyUDPChannel.AddResp(aResp: TROResponseItem);
begin
  FRespStorage.AddResp(aResp);
end;

procedure TROIndyUDPChannel.RemoveResp(aResp: TROResponseItem);
begin
  FRespStorage.RemoveResp(aResp);
end;

procedure TROIndyUDPChannel.RemoveRespByUID(aUID: String);
begin
  FRespStorage.RemoveRespByUID(aUID);
end;

procedure TROIndyUDPChannel.DeleteResp(Index: Integer);
begin
  FRespStorage.DeleteResp(Index);
end;

function  TROIndyUDPChannel.GetResp(Index: Integer): TROResponseItem;
begin
  Result:=FRespStorage.ResponseItem[Index];
end;

function  TROIndyUDPChannel.GetRespByUID(aUID: String): TROResponseItem;
begin
  Result:=FRespStorage.GetRespByUID(aUID);
end;

function  TROIndyUDPChannel.GetResponseByUID(aUID: String): TROResponseItem;
begin
  Result:=FRespStorage.GetRespByUID(aUID);
end;

function  TROIndyUDPChannel.IndexOfResp(aResp: TROResponseItem): Integer;
begin
  Result:=FRespStorage.IndexOfResp(aResp);
end;

function  TROIndyUDPChannel.CountOfResp: Integer;
begin
  Result:=FRespStorage.CountOfResp;
end;

procedure TROIndyUDPChannel.ClearStorage;
begin
  FRespStorage.ClearStorage;
end;
{$ENDIF FPC}

initialization
  RegisterTransportChannelClass(TROIndyUDPChannel);

finalization
  UnRegisterTransportChannelClass(TROIndyUDPChannel);

end.