487 lines
14 KiB
ObjectPascal
487 lines
14 KiB
ObjectPascal
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.
|