unit uRONamedPipeChannel;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Enterprise Library                                }
{                                                                            }
{ compiler: Delphi 5 and up                                                  }
{ platform: Win32                                                            }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Provided by Robert Love (robert.love@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}

//TODO: Make sure with testing that client behaves well when server connection broken.

interface

uses
  {$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
  Classes, Sysutils, uROClient, uROClientIntf, uROClasses, uROTypes, Windows;

type
  TRONamedPipeChannel = class(TROTransportChannel,IROTransport)
  private
   fServerName: string;
   fServerID: string;
   FActive: Boolean;
   FActivateOnDemand: Boolean;
   procedure SetServerID(const Value: string);
   procedure SetServerName(const Value: string);
   procedure SetActive(const Value: Boolean);
   procedure SetActivateOnDemand(const Value: Boolean);
  protected
   hPipe : THandle;

   procedure IntDispatch(aRequest, aResponse : TStream); override;
   function GetPipeName : string;  virtual;
   procedure SendAndRecv(aRequest, aResponse : TStream); virtual;
   function DataWaiting: Boolean; virtual;

   { IROTransport }
   function GetTransportObject : TObject; override;

  public
   constructor Create(Owner : TComponent); override;
   destructor Destroy; override;
   procedure Connect; virtual;
   procedure Disconnect; virtual;
   procedure CheckProperties; override;
  published
   property ActivateOnDemand : Boolean read FActivateOnDemand write SetActivateOnDemand default true;
   property Active : Boolean read FActive write SetActive default false;
   property ServerID : string read fServerID write SetServerID;
   property ServerName : string read fServerName write SetServerName;
  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
{ TRONamedPipeChannel }

procedure TRONamedPipeChannel.connect;
var
 dwmode : DWord;
begin
    hPipe := CreateFile(
       pchar(GetPipeName),   // pipe name
       GENERIC_READ or       // read and write access
       GENERIC_WRITE,
       0,              // no sharing
       nil,            // no security attributes
       OPEN_EXISTING,  // opens existing pipe
       0,              // default attributes
       0);             // no template file

   FActive := not (hPipe= INVALID_HANDLE_VALUE);
   if (GetLastError = ERROR_PIPE_BUSY) then
    begin
      // All pipe instances are busy, so wait for 20 seconds.
      if (not WaitNamedPipe(pchar(GetPipeName), 20000) ) then
       begin
        FActive := False;
        raise EROChannelBusy.Create('Named Pipe Server is Busy');
       end;
      hPipe := CreateFile(
         pchar(GetPipeName),   // pipe name
         GENERIC_READ or       // read and write access
         GENERIC_WRITE,
         0,              // no sharing
         nil,            // no security attributes
         OPEN_EXISTING,  // opens existing pipe
         0,              // default attributes
         0);             // no template file
      FActive := not (hPipe= INVALID_HANDLE_VALUE);
   end;
   if Not FActive then RaiseLastOSError;

   dwMode := PIPE_READMODE_MESSAGE;
   if not SetNamedPipeHandleState(
          hPipe,    // pipe handle
          dwMode,  // new pipe mode
          nil,      // don't set maximum bytes
          nil)      // don't set maximum time
     Then
      begin
       Disconnect;
       raise Exception.Create('Unable to change to Message Read Mode');
      end;
end;

procedure TRONamedPipeChannel.Disconnect;
begin
  CloseHandle(hPipe);
  FActive := False;
end;

constructor TRONamedPipeChannel.Create(Owner: TComponent);
begin
 inherited Create(Owner);
 FActivateOnDemand := true;
 FActive := false;
 FServerID := 'RONamedPipeServer';
 fServerName := '.'; // localhost
end;

function TRONamedPipeChannel.GetTransportObject: TObject;
begin
 result := self;
end;

procedure TRONamedPipeChannel.IntDispatch(aRequest, aResponse: TStream);
begin
 if (Not FActive) and (Not FActivateOnDemand) then
  raise Exception.Create('Operation can not be performed on a closed connection.');
 if (Not Factive) then
   Connect;
 SendAndRecv(aRequest,aResponse);
 if FActivateOnDemand then
   Disconnect;
end;

function TRONamedPipeChannel.GetPipeName: string;
begin
  CheckProperties;
  result := '\\' + fServerName + '\pipe\' + fServerID;
end;

procedure TRONamedPipeChannel.SendAndRecv(aRequest, aResponse: TStream);
var
 fBuf : PChar;
 FSize : Integer;
 fSuccess : BOOL;
 FBytes   : DWord;
 BufSize  : integer;
begin
  //  ViktorT changed
  BufSize := 4096;
  GetMem(fBuf, BufSize);

  try
    try
      aRequest.Position := 0;
      FSize := aRequest.Size;
      //  Send Request size to recipient (server)
      fSuccess := WriteFile(hPipe, FSize, sizeof(FSize), FBytes, nil);

      if not FSuccess then
        RaiseLastOSError;

      while FSize > 0 do
      begin
        FBytes := aRequest.Read(fBuf^, BufSize);
        dec(FSize, FBytes);
        fSuccess := WriteFile(hPipe, fBuf^, FBytes, FBytes, nil);

        if not FSuccess then
          RaiseLastOSError;
      end;

      if not FSuccess then
        RaiseLastOSError;

      fSuccess := ReadFile(hPipe, FSize, sizeof(FSize), FBytes, nil);

      if not FSuccess then
        RaiseLastOSError;

      while FSize > 0 do
      begin
        fSuccess := ReadFile(hPipe, fBuf^, BufSize, FBytes, nil);

        if (not fSuccess) and (GetLastError <> ERROR_MORE_DATA) then
          RaiseLastOSError;

        if  FBytes > 0  then
          aResponse.Write(fBuf^, FBytes);

        dec(FSize, FBytes);
      end;
    except
      on e: Exception do
      begin
        Factive := False;
        CloseHandle(hPipe);
      end;
    end;
  finally
    FreeMem(fBuf);
  end;
(*
 FSize := aRequest.Size;
 GetMem(fBuf,FSize);
 try
   FillChar(fBuf^,FSize,0);
   aRequest.Seek(0,soFromBeginning);
   aRequest.ReadBuffer(fBuf[0],FSize);
   // Send Buffer to Server
   fSuccess := WriteFile(
      hPipe,                  // pipe handle
      fBuf[0],                // message
      FSize,                  // message length
      FBytes,                 // bytes written
      nil) ;                  // not overlapped
   if not FSuccess then
   begin
     //  ViktorT
     Factive := False;
     RaiseLastOSError;
   end;
   While Not DataWaiting do
     Sleep(10);

   while DataWaiting do
    begin
        // Read from the pipe.
       fSuccess := ReadFile(
          hPipe,          // pipe handle
          fBuf[0],        // buffer to receive reply
          fSize,          // size of buffer
          FBytes,         // number of bytes read
          nil);           // not overlapped
       if (Not fSuccess) and (GetLastError <> ERROR_MORE_DATA) then
       begin
          //  ViktorT
          Factive := False;
          RaiseLastOSError;
       end;
       if Fbytes > 0 then
          aResponse.WriteBuffer(FBuf[0],fBytes);
     end;
 finally
  FreeMem(fBuf);
 end; // finally
*)
end; // SendAndRecv


function TRONamedPipeChannel.DataWaiting: Boolean;
var
 fSuccess : BOOL;
 BytesAvail : Integer;
begin
  FSuccess := PeekNamedPipe(hPipe,nil,0,nil,@BytesAvail,nil);
  if not FSuccess then
  begin
    //  ViktorT
    Factive := False;
    RaiseLastOSError;
  end;
  result := (BytesAvail >0);
end; // DataWaiting


procedure TRONamedPipeChannel.SetActivateOnDemand(const Value: Boolean);
begin
  FActivateOnDemand := Value;
end;

procedure TRONamedPipeChannel.SetActive(const Value: Boolean);
begin
 if FActive <> Value then
  begin
    if Value
     then Connect
     else Disconnect;
  end;
end;


procedure TRONamedPipeChannel.SetServerID(const Value: string);
begin
  fServerID := Value;
end;

procedure TRONamedPipeChannel.SetServerName(const Value: string);
begin
  fServerName := Value;
end;


procedure TRONamedPipeChannel.CheckProperties;
begin
  Check(ServerID = '', Name+'.ServerID must be set.');
  Check(ServerName = '', Name+'.ServerName must be set.');
  inherited;
end;

destructor TRONamedPipeChannel.Destroy;
begin
  if FActive then begin
    Disconnect;
  end;
  inherited;
end;

initialization
  RegisterTransportChannelClass(TRONamedPipeChannel);

finalization
  UnRegisterTransportChannelClass(TRONamedPipeChannel);

end.