unit uRONamedPipeServer;

{----------------------------------------------------------------------------}
{ 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: Add OnFatalException Handler to send exception to main thread to be raised.

interface

{$WARN SYMBOL_DEPRECATED OFF} // This unit is only for Win32

uses
  {$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
  Sysutils,Classes, Windows, Messages, uROClientIntf, uROServer, uROClasses, uROThread;

const
  PIPE_TIMEOUT = 1000;
  BUFFER_SIZE  = 4096;

type
  TRONamedPipeServer = class;

  TROPipeListenerThread = class(TThread)
  private
    { Private declarations }
    fPipename : string;
    FList : TThreadList;
    FServer : TRONamedPipeServer;
    FFatalError: TObject;
    hPipe : THandle;
    procedure ConnectOnTerminate(Sender : TObject);
    function GetPipename: String;
    procedure SetPipeName(const Value: String);
    procedure RaiseException;
    procedure EmulateConnect;
  protected
    procedure Execute; override;
    property PipeName : String read GetPipename write SetPipeName;
    property ConnectList : TThreadList read FList;
    property Server : TRONamedPipeServer read FServer Write FServer;
    property FatalError : TObject read FFatalError write FFatalError;
  end;

  TROPipeConnectionThread = class(TROThread)
  private
    FPipeHandle: THandle;
    fTransport : IROTransport;
    FServer : TRONamedPipeServer;
    FFatalError: TObject;
    procedure Disconnect;
    procedure RaiseException;
  protected
    procedure Execute; override;
    property PipeHandle : THandle read FPipeHandle write FPipeHandle;
    property Transport : IROTransport read FTransport write FTransport;
    property Server : TRONamedPipeServer read FServer Write FServer;
    property FatalError : TObject read FFatalError write FFatalError;
  public
    constructor Create(aCreateSuspended:Boolean);
  end;

  TRONamedPipeServer = class(TROServer, IROTransport)
  private
    fServerID: string;
    fTransport : IROTransport;
    FActive : Boolean;
    FListener : TROPipeListenerThread;
    FAllowEveryone : Boolean;
  protected
    { Internals }
    procedure IntSetActive(const Value: boolean); override;
    function IntGetActive : boolean; override;

    procedure ActivateServer; virtual;
    property Listener: TROPipeListenerThread read FListener;

   { IROTransport }
    function GetTransportObject : TObject;
  public
    constructor Create(aOwner : TComponent); override;
    destructor Destroy; override;
    procedure CheckProperties; override;
  published
    property ServerID : string read fServerID write fServerID;
    property AllowEveryone : Boolean read FAllowEveryone write FAllowEveryone default false;
  end;

implementation

procedure TROPipeListenerThread.ConnectOnTerminate(Sender: TObject);
var
 LL : TList;
 id : Integer;
begin
 if Terminated then Exit;
 LL := FList.LockList;
 try
 id := LL.IndexOf(sender);
 if id >= 0 then
   LL.Delete(id);
 finally
  FList.UnlockList;
 end;
end;

procedure TROPipeListenerThread.EmulateConnect;
var
 i: cardinal;
begin
 if hPipe <> INVALID_HANDLE_VALUE then
   CallNamedPipe(pchar(fPipeName), nil, 0, nil, 0, i, 10);
end;

{$IFDEF FPC}
const
  PIPE_UNLIMITED_INSTANCES = 255;
{$ENDIF}

procedure TROPipeListenerThread.Execute;
var
 fconnected : bool;
 PC :  TROPipeConnectionThread;
 LL : TList;
 I  : Integer;
 lSecurityDescriptor : _SECURITY_DESCRIPTOR;
 lSecurityAttribute : SECURITY_ATTRIBUTES;
begin
 hPipe := INVALID_HANDLE_VALUE;
 try
  if FServer.AllowEveryone then begin
    FillChar(lSecurityAttribute, sizeof(lSecurityAttribute), 0);
    InitializeSecurityDescriptor(@lSecurityDescriptor, SECURITY_DESCRIPTOR_REVISION);
    SetSecurityDescriptorDacl(@lSecurityDescriptor, true, nil, False);
    lSecurityAttribute.nLength := sizeof(lSecurityAttribute);
    lSecurityAttribute.bInheritHandle := True;
    lSecurityAttribute.lpSecurityDescriptor := @lSecurityDescriptor;
  end;
  FList := TThreadList.Create;
  try
  While not Terminated do
   begin
     if FServer.AllowEveryone then begin
      hPipe := CreateNamedPipe(
          pchar(fPipeName),      // pipe name
          PIPE_ACCESS_DUPLEX,       // read/write access
          PIPE_TYPE_MESSAGE or      // message type pipe
          PIPE_READMODE_BYTE or     // byte-read mode
          PIPE_WAIT,                // blocking mode
          PIPE_UNLIMITED_INSTANCES, // max. instances
          BUFFER_SIZE,              // output buffer size
          BUFFER_SIZE,              // input buffer size
          PIPE_TIMEOUT,             // client time-out
          @lSecurityAttribute);
      end else begin
      hPipe := CreateNamedPipe(
          pchar(fPipeName),      // pipe name
          PIPE_ACCESS_DUPLEX,       // read/write access
          PIPE_TYPE_MESSAGE or      // message type pipe
          PIPE_READMODE_BYTE or     // byte-read mode
          PIPE_WAIT,                // blocking mode
          PIPE_UNLIMITED_INSTANCES, // max. instances
          BUFFER_SIZE,              // output buffer size
          BUFFER_SIZE,              // input buffer size
          PIPE_TIMEOUT,             // client time-out
          nil);                     // no security attribute
      end;

      if (hPipe = INVALID_HANDLE_VALUE) then
        RaiseLastOSError;

      // Wait for the client to connect; if it succeeds,
      // the function returns a nonzero value. If the function returns
      // false, GetLastError should returns ERROR_PIPE_CONNECTED.
      fConnected := ConnectNamedPipe(hPipe, nil);
      if not fConnected then
         fConnected := (GetLastError = ERROR_PIPE_CONNECTED);

      if fConnected  and not Terminated then
      begin
          PC := TROPipeConnectionThread.create(true);
          PC.PipeHandle := hPipe;
          PC.Server := FServer;
          PC.FreeOnTerminate := True;
          PC.Resume;
      end
      else
      begin
        // The client could not connect, so close the pipe.
         CloseHandle(hPipe);
         hPipe := INVALID_HANDLE_VALUE;
      end;
   end;
  finally
   LL := FList.LockList;
   try
   // Terminate all client connections because if here then this thread is terminating
   for I := 0 to LL.Count -1 do
     TROPipeConnectionThread(LL.Items[I]).Terminate;
   finally
     FList.UnlockList;
   end;
   FList.Free;
  end;
 except
   on e : TObject do
    begin
      FatalError := E;
      // Make sure exception is raised in main thread.
      Synchronize(RaiseException);
    end;
 end; // except
end;

function TROPipeListenerThread.GetPipename: String;
begin
 result := string(fPipeName);
end;

procedure TROPipeListenerThread.RaiseException;
begin
  raise FatalError;
end;

procedure TROPipeListenerThread.SetPipeName(const Value: String);
begin
 fPipeName := Value;
end;

{ TROPipeConnectionThread }

constructor TROPipeConnectionThread.Create(aCreateSuspended:Boolean);
begin
  inherited Create(aCreateSuspended,'TROPipeConnectionThread');
end;
{
function TROPipeConnectionThread.DataWaiting: Boolean;
var
 fSuccess : BOOL;
 BytesAvail : Integer;
begin
  FSuccess := PeekNamedPipe(FPipeHandle,nil,0,nil,@BytesAvail,nil);
  if not FSuccess then
    RaiseLastWin32Error;
  result := (BytesAvail >0);
end;
}
procedure TROPipeConnectionThread.Disconnect;
begin
// Flush the pipe to allow the client to read the pipe's contents
// before disconnecting. Then disconnect the pipe, and close the
// handle to this pipe instance.
   FlushFileBuffers(FPipeHandle);
   DisconnectNamedPipe(FPipeHandle);
   CloseHandle(FPipeHandle);
end;

procedure TROPipeConnectionThread.Execute;
var
 ReadStream,
 WriteStream : TMemoryStream;
 fBytesRead,fBytesWritten : DWORD;
 fSuccess : BOOL;
 fDataSize: integer;
 fBuf: PChar;
begin
  GetMem(fBuf, BUFFER_SIZE);
  readStream  := TMemoryStream.Create;
  writeStream := nil;
  try
    try
      While Not Terminated do
      begin
        // Read incomming Data
        fSuccess := ReadFile(fPipeHandle, fDataSize, sizeof(fDataSize), fBytesRead, nil);

        if Not fSuccess then
          if  GetLastError = ERROR_BROKEN_PIPE then
            //  The pipe has been ended
            break
          else
            RaiseLastOSError;

        while fDataSize > 0 do
        begin
          fSuccess := ReadFile(fPipeHandle, fBuf^, BUFFER_SIZE, fBytesRead, nil);

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

          if  fBytesRead > 0  then
            ReadStream.Write(fBuf^, fBytesRead);

          dec(fDataSize, fBytesRead);
        end;

        if not FSuccess then
          RaiseLastOSError;

        if  ReadStream.Size > 0 then
        begin
          writeStream := TMemoryStream.Create;
          ReadStream.Position := 0;
          FServer.DispatchMessage(fServer.FTransport, ReadStream, writeStream);
          ReadStream.Position := 0;
          ReadStream.SetSize(0);
          writeStream.Position := 0;
          fDataSize := writeStream.Size;
          fSuccess := WriteFile(fPipeHandle, fDataSize, sizeof(fDataSize), fBytesWritten, nil);

          if not fSuccess then
            RaiseLastOSError;

          while fDataSize > 0 do
          begin
            fBytesRead := writeStream.Read(fBuf^, BUFFER_SIZE);
            dec(fDataSize, fBytesRead);
            fSuccess := WriteFile(fPipeHandle, fBuf^, fBytesRead, fBytesWritten, nil);

            if not FSuccess then
              RaiseLastOSError;
          end;
        end;
      end;
    except
      on e: Exception do
      begin
        // Only expected message is a broken pipe and it should be ignored.
        if not ((e is EWin32Error)
          and ((EWin32Error(E).ErrorCode = ERROR_BROKEN_PIPE)
               {or (EWin32Error(E).ErrorCode = ERROR_NO_DATA)})) then
        begin
          FatalError := E;
          // Make sure exception is raised in main thread.
          Synchronize(RaiseException);
        end;
      end;
    end;
  finally
    FreeMem(fBuf);
    ReadStream.Free;
    WriteStream.Free;
    Disconnect;
    if FServer.FListener <> nil then fServer.FListener.ConnectOnTerminate(self);
 end;
(*
    // Read incomming Data
    // Empty incomming buffer into Stream
    FSuccess := True;
    while DataWaiting do
     begin
       fSuccess := ReadFile(fPipeHandle,ReadBuf,BUFFER_SIZE,fBytesRead,nil);
       if (Not fSuccess) and (GetLastError <> ERROR_MORE_DATA) then
         Break;
       if (FBytesRead > 0) then
          ReadStream.WriteBuffer(ReadBuf[0],fBytesRead);
       if fSuccess then break;
     end;
    if Not FSuccess then
     RaiseLastWIn32Error;
    fIncommingData := (FSuccess and (ReadStream.Size > 0));
    if FIncommingData then
     begin
       // Transport Data
        WriteStream.Clear;
        FServer.DispatchMessage(fServer.FTransport, Readstream, Writestream);
        ReadStream.Clear;
       // Write Contents from RO back out Pipe
       fBytesRead := 1; //just to start loop
       While FBytesRead > 0 do
       begin
         fBytesRead := WriteStream.Read(WriteBuf,BUFFER_SIZE);
         if FBytesRead > 0 then
          begin
           fSuccess := WriteFile(FPipeHandle,WriteBuf,fBytesRead,fBytesWritten,nil);
           if (not FSuccess) then
              RaiseLastWin32Error;
           end;
       end;  // while FBytesRead > 0
     end; // if FIncommingData
   end; // while not terminated

 finally
   Disconnect;
   ReadStream.Free;
   WriteStream.Free;
 end;
except
  on e: Exception do
   begin
   // Only expected message is a broken pipe and it should be ignored.
    if not ((e is EWin32Error) and (EWin32Error(E).ErrorCode = ERROR_BROKEN_PIPE)) then
     begin
      FatalError := E;
      // Make sure exception is raised in main thread.
      Synchronize(RaiseException);
     end;
   end;
end; //except
*)
end;


procedure TROPipeConnectionThread.RaiseException;
begin
 raise FatalError;
end;

{ TRONamedPipeServer }

procedure TRONamedPipeServer.ActivateServer;
begin
if FActive then
 begin
   CheckProperties;
   FListener := TROPipeListenerThread.create(true);
   FListener.PipeName := '\\.\pipe\'+ ServerID;
   FListener.FreeOnTerminate := True;
   FListener.Server := Self;
   FListener.Resume;
 end
 else begin
   FListener.Terminate;
   FListener.EmulateConnect;
 end;
end;

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

constructor TRONamedPipeServer.Create(aOwner: TComponent);
begin
  inherited;
  Supports(Self, IROTransport, fTransport);
  if Assigned(Owner) then
     fServerID := Owner.Name + '_RONamedPipeServer'
  else
     fServerID := 'RONamedPipeServer'
end;

destructor TRONamedPipeServer.Destroy;
begin
  Active := False;
  inherited;
end;

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

function TRONamedPipeServer.IntGetActive: boolean;
begin
   result := Factive;
end;

procedure TRONamedPipeServer.IntSetActive(const Value: boolean);
begin
 if Value <> FActive then
  begin
    FActive := Value;
    if not (csDesigning in ComponentState) then
      ActivateServer;
  end;
end;

initialization
  RegisterServerClass(TRONamedPipeServer);
finalization
  UnregisterServerClass(TRONamedPipeServer);
end.