david
2a98435b14
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@68 b6239004-a887-0f4b-9937-50029ccdca16
995 lines
32 KiB
ObjectPascal
995 lines
32 KiB
ObjectPascal
unit uROZeroConfHub;
|
|
|
|
{$I RemObjects.inc}
|
|
{.$DEFINE uROZeroConfHub_DEBUG}
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF MSWINDOWS}Windows, SyncObjs,{$ENDIF}SysUtils, Classes,
|
|
uROClasses, uROThread,uROThreadPool, uROClient, uROZeroConfStreamWorker;
|
|
|
|
const
|
|
//ZeroConfBrowseFlags
|
|
hbNone = 0;
|
|
hbMoreComing = 1;
|
|
hbDeleted = 2;
|
|
// from Winsock2
|
|
AF_UNSPEC = 0;
|
|
AF_INET = 2;
|
|
AF_INET6 = 23;
|
|
|
|
type
|
|
TROZeroConfRegistrationResult = procedure(aHandle: String; aUserData: Pointer; aName, aService, aDomain: UnicodeString; anErrorCode: integer);
|
|
TROZeroConfResolveAddressResult = procedure(aHandle: String; aUserData: Pointer; aFullName: Unicodestring; anIP: string; aIPType: integer);
|
|
TROZeroConfResolveServiceResult = procedure(aHandle: String; aUserData: Pointer; aName, aType, aDomain, aLocalAddress: Unicodestring; aPort: integer; aText: TROHubBytes);
|
|
TROZeroConfResolveBrowseResult = procedure(aHandle: String; aUserData: Pointer; aName, aType, aDomain: Unicodestring; aFlags: integer);
|
|
|
|
TROStreamWorkerCallback = procedure(aData: TROHubBytes) of object;
|
|
|
|
TriggerDelegate = procedure of object;
|
|
|
|
TROWaitingRequest = class
|
|
private
|
|
fwh: TROEvent;
|
|
fTrigger: TriggerDelegate;
|
|
fName: Unicodestring;
|
|
FArgs: TKeyValuePair;
|
|
procedure EventTrigger;
|
|
public
|
|
constructor Create(ACreateWithEventSupport: Boolean = False);
|
|
destructor Destroy; override;
|
|
property Event:TROEvent read fwh;
|
|
property Trigger: TriggerDelegate read fTrigger write FTrigger;
|
|
property Name: Unicodestring read fName write fName;
|
|
property Args: TKeyValuePair read FArgs write FArgs;
|
|
end;
|
|
|
|
TRODictionary = class
|
|
private
|
|
fItems:TStringList;
|
|
FLock: TRTLCriticalSection;
|
|
protected
|
|
function Lock: TStringList;
|
|
procedure Unlock;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function TryGetValue(aKey: string; out aValue: TObject): boolean;overload;
|
|
procedure Remove(aKey: string);overload;
|
|
procedure Add(aKey: string; aValue: TObject);overload;
|
|
function TryGetValue(aKey: integer; out aValue: TObject): boolean;overload;
|
|
procedure Remove(aKey: integer);overload;
|
|
procedure Add(aKey: integer; aValue: TObject);overload;
|
|
end;
|
|
|
|
|
|
TDelegateType = (zcRegistration, zcResolveAddress, zcResolveService, zcResolveBrowse);
|
|
MulticastDelegate = record
|
|
aType: TDelegateType;
|
|
case TDelegateType of
|
|
zcRegistration: (RegistrationResult:TROZeroConfRegistrationResult);
|
|
zcResolveAddress: (ResolveAddressResult:TROZeroConfResolveAddressResult);
|
|
zcResolveService: (ResolveServiceResult: TROZeroConfResolveServiceResult);
|
|
zcResolveBrowse: (ResolveBrowseResult: TROZeroConfResolveBrowseResult);
|
|
end;
|
|
|
|
TROZeroConfHandle = class
|
|
public
|
|
Handle: TROHubBytes;
|
|
UserData: Pointer;
|
|
Delegate: MulticastDelegate;
|
|
end;
|
|
|
|
TZeroConfHubClient = class;
|
|
|
|
TROServiceSetup = class
|
|
private
|
|
fWaitingRequest : TROWaitingRequest;
|
|
fWaitHandle: TROEvent;
|
|
fHandle: TROZeroConfHandle;
|
|
fGenID: integer;
|
|
fOwner: TZeroConfHubClient;
|
|
fHandleVal : String;
|
|
public
|
|
constructor Create(aOwner: TZeroConfHubClient; aUserData: Pointer; aDelegate: MulticastDelegate);
|
|
destructor Destroy;override;
|
|
procedure Trigger;
|
|
function GetResult: String;
|
|
property GenID: Integer read fGenID;
|
|
end;
|
|
|
|
TZeroConfHubClient = class(TObject, IROStreamWorkerCallbacks)
|
|
private
|
|
fWorker: TROStreamWorker;
|
|
fWaitingRequests: TRODictionary;
|
|
fHandles: TRODictionary;
|
|
fCommandTimeout: integer;
|
|
fBlockResolveEvent: TROEvent;
|
|
fBlockPort: integer;
|
|
fBlockText: TROHubBytes;
|
|
fBlockFullName: Unicodestring;
|
|
fBlockIP4,fBlockIP6: string;
|
|
fBlockLocalAddress: Unicodestring;
|
|
fBlockOrigIpType: integer;
|
|
fPool: TROThreadPool;
|
|
procedure HandleEvent_RegistrationFailed(aHandle: TROHubBytes;aName, aService, aDomain: UnicodeString; anErrorCode: integer);
|
|
procedure HandleEvent_RegistrationSucceeded(aHandle: TROHubBytes;aName, aService, aDomain: UnicodeString);
|
|
procedure HandleEvent_ResolveAddressResult(aHandle: TROHubBytes;aFullName: UnicodeString; anIP: TROHubBytes);
|
|
procedure HandleEvent_ResolveServiceResult(aHandle: TROHubBytes;aName, aType, aDomain, aLocalAddress: Unicodestring; aPort: integer; aText: TROHubBytes);
|
|
procedure HandleEvent_ResolveBrowseResult(aHandle: TROHubBytes; aName, aType, aDomain: Unicodestring; aFlags: integer);
|
|
procedure HandleEvent(lName: UnicodeString; lArgs: TKeyValuePair);
|
|
procedure SendCommand_CloseHandle(aHandle: TROHubBytes);
|
|
procedure CloseHandles;
|
|
function GetRunning: boolean;
|
|
protected
|
|
{ IInterface }
|
|
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
|
|
function _AddRef: Integer; stdcall;
|
|
function _Release: Integer; stdcall;
|
|
// IROStreamWorkerCallbacks
|
|
procedure ControlCommand(aSender: TROStreamWorker; aName: UnicodeString; aArguments: TKeyValuePair);
|
|
procedure Data(aSender: TROStreamWorker; aData: TROHubBytes);
|
|
procedure Disconnected(aSender: TROStreamWorker);
|
|
function CreateTCPClient: TTCPStream; virtual; abstract;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Start;
|
|
procedure Stop;
|
|
procedure CloseHandle(aHandle: String);
|
|
function GetMyHostName: UnicodeString;
|
|
function RegisterService(const aName, aService, aDomain: UnicodeString; const aFlags: integer; const aHost: Unicodestring; const aPort: integer; const aText: TROHubBytes; const aUserData: Pointer; const aDelegate: TROZeroConfRegistrationResult): String;
|
|
function ResolveAddress(const aFullName: UnicodeString; const aUserData: Pointer; const aDelegate: TROZeroConfResolveAddressResult):String;
|
|
function ResolveService(const aServiceName, aServiceType, aDomain: UnicodeString; const aUserData: Pointer; const aDelegate: TROZeroConfResolveServiceResult):String;
|
|
function BrowseService(const aServiceType, aDomain: UnicodeString; const aUserData: Pointer; const aDelegate: TROZeroConfResolveBrowseResult):String;
|
|
function BlockResolve(const aTimeout: integer; aServiceName, aServiceType, aDomain: UnicodeString; aIPType: integer; out aFullName, aLocalAddress: Unicodestring; out aPort: integer; out aText: TROHubBytes; out anIP4, anIP6: string): boolean;
|
|
property Running: boolean read GetRunning;
|
|
property CommandTimeout: integer read fCommandTimeout write fCommandTimeout default 10000;
|
|
end;
|
|
|
|
TZeroConfHubClientClass = class of TZeroConfHubClient;
|
|
|
|
implementation
|
|
|
|
const
|
|
HUB_PORT = 16565;
|
|
HUB_HOST = '127.0.0.1';
|
|
|
|
function FindParameter(aArgs: TKeyValuePair; aName: UnicodeString):TROHubBytes; forward;
|
|
function RemoveLastDot(aValue: Unicodestring): UnicodeString; forward;
|
|
function HandleToString(aHandle: TROHubBytes): String; forward;
|
|
procedure ProcessException(aArgs: TKeyValuePair);forward;
|
|
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'shared functions'}{$ENDIF DELPHI10UP}
|
|
|
|
function FindParameter(aArgs: TKeyValuePair; aName: UnicodeString): TROHubBytes;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to Length(aArgs) - 1 do begin
|
|
if ROWideCompare(aArgs[i].ArgName, aName, True)=0 then begin
|
|
Result := aArgs[i].ArgValue;
|
|
Exit;
|
|
end;
|
|
end;
|
|
raise Exception.CreateFmt('No such parameter: %s',[aName]);
|
|
end;
|
|
|
|
function RemoveLastDot(aValue: Unicodestring): UnicodeString;
|
|
begin
|
|
Result := aValue;
|
|
if EndsWith('.',Result) then SetLength(Result, Length(Result)-1);
|
|
end;
|
|
|
|
function HandleToString(aHandle: TROHubBytes): String;
|
|
var
|
|
lguid: TGUID;
|
|
begin
|
|
lguid.D1 := ord(aHandle[1])+ord(aHandle[2])*$100+ord(aHandle[3])*$10000+ord(aHandle[4])*$1000000;
|
|
lguid.D2 := ord(aHandle[5])+ord(aHandle[6])*$100;
|
|
lguid.D3 := ord(aHandle[7])+ord(aHandle[8])*$100;
|
|
Move(aHandle[9],lguid.D4[0],8);
|
|
Result:= GUIDToString(lguid);
|
|
end;
|
|
|
|
procedure ProcessException(aArgs: TKeyValuePair);
|
|
var
|
|
lCode: integer;
|
|
lClass: Unicodestring;
|
|
lMessage: unicodestring;
|
|
i: integer;
|
|
begin
|
|
lCode := 0;
|
|
lMessage := 'Exception from server';
|
|
for i := 0 to Length(aArgs) - 1 do begin
|
|
if ROWideCompare(aArgs[i].ArgName, 'class', True) = 0 then begin
|
|
lclass := UTF8ToString(aArgs[i].ArgValue);
|
|
end
|
|
else if ROWideCompare(aArgs[i].ArgName, 'code' ,True) = 0 then begin
|
|
lCode := Int32FromBuffer(aArgs[i].ArgValue);
|
|
end
|
|
else if ROWideCompare(aArgs[i].ArgName, 'message' ,True) = 0 then begin
|
|
lMessage := UTF8ToString(aArgs[i].ArgValue);
|
|
end;
|
|
end;
|
|
raise EROZeroConfHubException.Create(lMessage, lCode);
|
|
end;
|
|
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'TZeroConfHubClient methods'}{$ENDIF DELPHI10UP}
|
|
{ TZeroConfHubClient }
|
|
|
|
procedure cbBlockResolveAddress(aHandle: String; aUserData: Pointer; aFullName: Unicodestring; anIP: string; aIPType: integer);
|
|
begin
|
|
if Assigned(aUserData) then
|
|
with TZeroConfHubClient(aUserData) do begin
|
|
if aIPType = AF_INET then
|
|
fBlockIP4 := anIP
|
|
else
|
|
fBlockIP6 := anIP;
|
|
if ((fBlockOrigIpType = AF_UNSPEC) or (fBlockOrigIpType = aIPType)) and Assigned(fBlockResolveEvent) then fBlockResolveEvent.SetEvent;
|
|
end;
|
|
end;
|
|
|
|
procedure cbBlockResolveService(aHandle: String; aUserData: Pointer; aServiceName, aServiceType, aDomain, aLocalAddress: Unicodestring; aPort: integer; aText: TROHubBytes);
|
|
begin
|
|
if Assigned(aUserData) then
|
|
with TZeroConfHubClient(aUserData) do begin
|
|
fBlockLocalAddress := aLocalAddress;
|
|
fBlockPort := aPort;
|
|
fBlockText := aText;
|
|
ResolveAddress(aLocalAddress,aUserData,@cbBlockResolveAddress);
|
|
end;
|
|
end;
|
|
|
|
function TZeroConfHubClient.BlockResolve(const aTimeout: integer; aServiceName, aServiceType,
|
|
aDomain: UnicodeString; aIPType: integer; out aFullName, aLocalAddress: Unicodestring;
|
|
out aPort: integer; out aText: TROHubBytes; out anIP4, anIP6: string): boolean;
|
|
begin
|
|
{$IFDEF uROZeroConfHub_DEBUG}
|
|
OutputDebugString(PChar('BlockResolve, self= ' + intTohex(Cardinal(self),8)));
|
|
{$ENDIF}
|
|
fBlockResolveEvent := TROEvent.Create(nil, false, false,'');
|
|
try
|
|
fBlockFullName := aServiceName + '.' + aServiceType + '.' + aDomain;
|
|
fBlockOrigIpType := aIPType;
|
|
ResolveService(aServiceName,aServiceType,aDomain, Self, @cbBlockResolveService);
|
|
Result := fBlockResolveEvent.WaitFor(aTimeout*1000) = wrSignaled;
|
|
if (not Result) then begin
|
|
raise EROZeroConfHubException.Create('Timeout waiting for request', 0);
|
|
end
|
|
else begin
|
|
aFullName := fBlockFullName;
|
|
aLocalAddress := fBlockLocalAddress;
|
|
aPort := fBlockPort;
|
|
aText := fBlockText;
|
|
anIP4 := fBlockIP4;
|
|
anIP6 := fBlockIP6;
|
|
end;
|
|
finally
|
|
FreeAndNil(fBlockResolveEvent);
|
|
end;
|
|
end;
|
|
|
|
function TZeroConfHubClient.BrowseService(const aServiceType, aDomain: UnicodeString;
|
|
const aUserData: Pointer; const aDelegate: TROZeroConfResolveBrowseResult):String;
|
|
var
|
|
lServiceType,lDomain: UnicodeString;
|
|
lArgs: TKeyValuePair;
|
|
zc: TROServiceSetup;
|
|
delegate: MulticastDelegate;
|
|
begin
|
|
lServiceType := RemoveLastDot(aServiceType);
|
|
lDomain := RemoveLastDot(aDomain);
|
|
SetLength(lArgs,2);
|
|
lArgs[0].ArgName := 'aType'; lArgs[0].ArgValue := UnicodeStringToBytes(lServiceType);
|
|
lArgs[1].ArgName := 'aDomain'; lArgs[1].ArgValue := UnicodeStringToBytes(lDomain);
|
|
delegate.aType := zcResolveBrowse;
|
|
delegate.ResolveBrowseResult := aDelegate;
|
|
zc := TROServiceSetup.Create(Self, aUserData, delegate);
|
|
try
|
|
fWorker.SendData(EncodePackage('BrowseService', true, Int32ToBuffer(zc.GenID), lArgs));
|
|
Result := zc.GetResult;
|
|
finally
|
|
zc.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.CloseHandle(aHandle: String);
|
|
var
|
|
lHandle: TObject;
|
|
begin
|
|
if fHandles.TryGetValue(aHandle,lHandle) then begin
|
|
fHandles.Remove(aHandle);
|
|
if (lHandle <> nil) then begin
|
|
SendCommand_CloseHandle(TROZeroConfHandle(lHandle).Handle);
|
|
lHandle.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.CloseHandles;
|
|
var
|
|
lhandle: TROZeroConfHandle;
|
|
i: integer;
|
|
List: TStringList;
|
|
begin
|
|
List := fHandles.Lock;
|
|
try
|
|
for i := 0 to List.Count - 1 do begin
|
|
lhandle := TROZeroConfHandle(List.Objects[i]);
|
|
if lhandle <> nil then begin
|
|
try
|
|
SendCommand_CloseHandle(lhandle.Handle);
|
|
except
|
|
// catch exceptions
|
|
end;
|
|
lhandle.Free;
|
|
end;
|
|
end;
|
|
List.Clear;
|
|
finally
|
|
fHandles.Unlock;
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.ControlCommand(aSender: TROStreamWorker;
|
|
aName: UnicodeString; aArguments: TKeyValuePair);
|
|
begin
|
|
// nothing
|
|
end;
|
|
|
|
constructor TZeroConfHubClient.Create;
|
|
begin
|
|
inherited;
|
|
fPool := TROThreadPool.Create(nil);
|
|
fPool.MaxQueue := MaxInt;
|
|
fPool.MaxThreads := 1;
|
|
fPool.PoolThreads := 1;
|
|
fHandles := TRODictionary.Create;
|
|
fWaitingRequests := TRODictionary.Create;
|
|
fCommandTimeout := 90000; // 10 seconds
|
|
Start;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.Data(aSender: TROStreamWorker;
|
|
aData: TROHubBytes);
|
|
var
|
|
lName: Unicodestring;
|
|
lArgs: TKeyValuePair;
|
|
lPackage: integer;
|
|
w: TObject;
|
|
begin
|
|
DecodePackage(aData, 4, lName, lArgs);
|
|
lPackage := Int32FromBuffer(aData);
|
|
{$IFDEF uROZeroConfHub_DEBUG}
|
|
OutputDebugStringW(PWideChar('TZeroConfHubClient.Data. Name = ' + lName + ' package = '+ BoolToStr(lPackage > 0,True)));
|
|
{$ENDIF}
|
|
if (lPackage > 0) then begin
|
|
if fWaitingRequests.TryGetValue(lPackage, w) then begin
|
|
TROWaitingRequest(w).Name := lName;
|
|
TROWaitingRequest(w).Args := lArgs;
|
|
TROWaitingRequest(w).Trigger;
|
|
end;
|
|
end
|
|
else begin
|
|
HandleEvent(lName, lArgs);
|
|
end;
|
|
end;
|
|
|
|
destructor TZeroConfHubClient.Destroy;
|
|
begin
|
|
Stop;
|
|
FreeAndNil(fWaitingRequests);
|
|
FreeAndNil(fHandles);
|
|
FreeAndNil(fPool);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.Disconnected(aSender: TROStreamWorker);
|
|
begin
|
|
Stop();
|
|
end;
|
|
|
|
function TZeroConfHubClient.GetMyHostName: UnicodeString;
|
|
var
|
|
lArgs: TKeyValuePair;
|
|
wr: TROWaitingRequest;
|
|
lGenID: integer;
|
|
lOk: Boolean;
|
|
begin
|
|
wr := TROWaitingRequest.Create(True);
|
|
try
|
|
lGenID := fWorker.GenerateID(true);
|
|
fWaitingRequests.Add(lGenID, wr);
|
|
SetLength(lArgs,0);
|
|
fWorker.SendData(EncodePackage('GetMyHostName', true, Int32ToBuffer(lGenID), lArgs));
|
|
lOk := wr.Event.WaitFor(fCommandTimeout) = wrSignaled;// in ms
|
|
fWaitingRequests.Remove(lGenID);
|
|
if (not lOk) then raise EROZeroConfHubException.Create('Timeout waiting for request', 0);
|
|
if EndsWith('#Exception', wr.Name, True) then ProcessException(wr.Args);
|
|
Result := BytesToUnicodeString(FindParameter(wr.Args, 'Result'));
|
|
finally
|
|
wr.Free;
|
|
end;
|
|
end;
|
|
|
|
function TZeroConfHubClient.GetRunning: boolean;
|
|
begin
|
|
Result := Assigned(fWorker);
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.HandleEvent(lName: UnicodeString;
|
|
lArgs: TKeyValuePair);
|
|
begin
|
|
if lName = 'RegistrationFailed' then begin
|
|
HandleEvent_RegistrationFailed(
|
|
FindParameter(lArgs, 'aHandle'),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aName')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aService')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aDomain')),
|
|
Int32FromBuffer(FindParameter(lArgs, 'anErrorCode')));
|
|
end
|
|
else if lName = 'RegistrationSucceeded' then begin
|
|
HandleEvent_RegistrationSucceeded(
|
|
FindParameter(lArgs, 'aHandle'),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aName')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aService')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aDomain')));
|
|
|
|
end
|
|
else if lName = 'ResolveAddressResult' then begin
|
|
HandleEvent_ResolveAddressResult(
|
|
FindParameter(lArgs, 'aHandle'),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aFullName')),
|
|
FindParameter(lArgs, 'anIP'));
|
|
end
|
|
else if lName = 'ResolveServiceResult' then begin
|
|
HandleEvent_ResolveServiceResult(
|
|
FindParameter(lArgs, 'aHandle'),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aName')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aType')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aDomain')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aLocalAddress')),
|
|
Int32FromBuffer(FindParameter(lArgs, 'aPort')),
|
|
FindParameter(lArgs, 'aText'));
|
|
end
|
|
else if lName = 'ResolveBrowseResult' then begin
|
|
HandleEvent_ResolveBrowseResult(
|
|
FindParameter(lArgs, 'aHandle'),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aName')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aType')),
|
|
BytesToUnicodeString(FindParameter(lArgs, 'aDomain')),
|
|
Int32FromBuffer(FindParameter(lArgs, 'aFlags')));
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TROHubPooledEvent = class(TInterfacedObject, IROThreadPoolCallback)
|
|
private
|
|
fHandle: TROZeroConfHandle;
|
|
fHandleVal: string;
|
|
//
|
|
aName, aType, aService, aDomain, aLocalAddress: UnicodeString;
|
|
aFullName: UnicodeString;
|
|
aPort, anErrorCode,aFlags: integer;
|
|
aIP: string;
|
|
aIPType: integer;
|
|
aText: TROHubBytes;
|
|
protected
|
|
procedure Callback(Caller: TROThreadPool; Thread: TThread);
|
|
public
|
|
constructor Create(aHandle: TROZeroConfHandle);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TROHubPooledEvent }
|
|
|
|
procedure TROHubPooledEvent.Callback(Caller: TROThreadPool;
|
|
Thread: TThread);
|
|
begin
|
|
if (fHandle <> nil) then
|
|
{$IFDEF uROZeroConfHub_DEBUG}
|
|
OutputDebugString(PChar('before TROHubPooledEvent.Callback, ID='+inttostr(ord(fHandle.Delegate.aType))));
|
|
{$ENDIF}
|
|
case fHandle.Delegate.aType of
|
|
zcRegistration: fHandle.Delegate.RegistrationResult(fHandleVal, fHandle.UserData, aName, aService, aDomain, anErrorCode);
|
|
zcResolveAddress: fHandle.Delegate.ResolveAddressResult(fHandleVal, fHandle.UserData, aFullName, aIP, aIPType);
|
|
zcResolveService: fHandle.Delegate.ResolveServiceResult(fHandleVal, fHandle.UserData, aName, aType, aDomain, aLocalAddress,aPort, aText);
|
|
zcResolveBrowse: fHandle.Delegate.ResolveBrowseResult(fHandleVal, fHandle.UserData, aName, aType, aDomain, aFlags);
|
|
end;
|
|
{$IFDEF uROZeroConfHub_DEBUG}
|
|
OutputDebugString(PChar('after TROHubPooledEvent.Callback, ID='+inttostr(ord(fHandle.Delegate.aType))));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
constructor TROHubPooledEvent.Create(aHandle: TROZeroConfHandle);
|
|
begin
|
|
inherited Create;
|
|
fHandle := aHandle;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.HandleEvent_RegistrationFailed(
|
|
aHandle: TROHubBytes; aName, aService, aDomain: UnicodeString;
|
|
anErrorCode: integer);
|
|
var
|
|
lHandle: TObject;
|
|
lHandleVal: string;
|
|
lpe: TROHubPooledEvent;
|
|
lpeEv : IROThreadPoolCallback;
|
|
begin
|
|
lHandle := nil;
|
|
lHandleVal := HandleToString(aHandle);
|
|
fHandles.TryGetValue(lHandleVal, lHandle);
|
|
if lHandle <> nil then begin
|
|
lpe := TROHubPooledEvent.Create(TROZeroConfHandle(lHandle));
|
|
//
|
|
lpe.fHandleVal := lHandleVal;
|
|
lpe.aName := aName;
|
|
lpe.aService:= aService;
|
|
lpe.aDomain := aDomain;
|
|
lpe.anErrorCode := anErrorCode;
|
|
//
|
|
lpeEv := lpe;
|
|
fPool.QueueItem(lpeEv);
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.HandleEvent_RegistrationSucceeded(
|
|
aHandle: TROHubBytes; aName, aService, aDomain: UnicodeString);
|
|
var
|
|
lHandle: TObject;
|
|
lHandleVal: string;
|
|
lpe: TROHubPooledEvent;
|
|
lpeEv : IROThreadPoolCallback;
|
|
begin
|
|
lHandle := nil;
|
|
lHandleVal := HandleToString(aHandle);
|
|
fHandles.TryGetValue(lHandleVal, lHandle);
|
|
if lHandle <> nil then begin
|
|
lpe := TROHubPooledEvent.Create(TROZeroConfHandle(lHandle));
|
|
//
|
|
lpe.fHandleVal := lHandleVal;
|
|
lpe.aName := aName;
|
|
lpe.aService:= aService;
|
|
lpe.aDomain := aDomain;
|
|
lpe.anErrorCode := 0;
|
|
//
|
|
lpeEv := lpe;
|
|
fPool.QueueItem(lpeEv);
|
|
end;
|
|
end;
|
|
|
|
function DecodeIP4(anIP: TROHubBytes): string;
|
|
begin
|
|
Result:=Format('%d.%d.%d.%d', [ord(anIP[1]),ord(anIP[2]),ord(anIP[3]),ord(anIP[4])]);
|
|
end;
|
|
|
|
function DecodeIP6(anIP: TROHubBytes): string;
|
|
begin
|
|
if Length(anIP) = 16 then begin
|
|
Result := Format('%.x:%.x:%.x:%.x:%.x:%.x:%.x:%.x',[
|
|
ord(anIP[1])*$100+ord(anIP[2]),ord(anIP[3])*$100+ord(anIP[4]),ord(anIP[5])*$100+ord(anIP[6]),ord(anIP[7])*$100+ord(anIP[8]),
|
|
ord(anIP[9])*$100+ord(anIP[10]),ord(anIP[11])*$100+ord(anIP[12]),ord(anIP[13])*$100+ord(anIP[14]),ord(anIP[15])*$100+ord(anIP[16])]);
|
|
Result := StringReplace( Result, ':0:0:', '::', [rfReplaceAll]);
|
|
Result := StringReplace( Result, ':0:', '::', [rfReplaceAll]);
|
|
Result := StringReplace( Result, ':::', '::', [rfReplaceAll]);
|
|
Result := StringReplace( Result, ':::', '::', [rfReplaceAll]);
|
|
Result := LowerCase(Result);
|
|
end
|
|
else
|
|
Result:= {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(anIP);
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.HandleEvent_ResolveAddressResult(aHandle: TROHubBytes;aFullName: UnicodeString; anIP: TROHubBytes);
|
|
var
|
|
lHandle: TObject;
|
|
lHandleVal: string;
|
|
lIP: string;
|
|
lIPType: integer;
|
|
lpe: TROHubPooledEvent;
|
|
lpeEv : IROThreadPoolCallback;
|
|
begin
|
|
if Length(anIP) = 4 then lIPtype := AF_INET else lIPtype := AF_INET6;
|
|
|
|
if lIPtype = AF_INET then
|
|
lIP := DecodeIP4(anIP)
|
|
else
|
|
lIP := DecodeIP6(anIP);
|
|
lHandle := nil;
|
|
lHandleVal := HandleToString(aHandle);
|
|
fHandles.TryGetValue(lHandleVal, lHandle);
|
|
|
|
if lHandle <> nil then begin
|
|
lpe := TROHubPooledEvent.Create(TROZeroConfHandle(lHandle));
|
|
//
|
|
lpe.fHandleVal := lHandleVal;
|
|
lpe.aFullName := aFullName;
|
|
lpe.aIP:= lIP;
|
|
lpe.aIPType := lIPType;
|
|
//
|
|
lpeEv := lpe;
|
|
fPool.QueueItem(lpeEv);
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.HandleEvent_ResolveBrowseResult(
|
|
aHandle: TROHubBytes; aName, aType, aDomain: Unicodestring;
|
|
aFlags: integer);
|
|
var
|
|
lHandle: TObject;
|
|
lHandleVal: string;
|
|
lpe: TROHubPooledEvent;
|
|
lpeEv : IROThreadPoolCallback;
|
|
begin
|
|
lHandle := nil;
|
|
lHandleVal := HandleToString(aHandle);
|
|
fHandles.TryGetValue(lHandleVal, lHandle);
|
|
if lHandle <> nil then begin
|
|
lpe := TROHubPooledEvent.Create(TROZeroConfHandle(lHandle));
|
|
//
|
|
lpe.aName := aName;
|
|
lpe.aType := aType;
|
|
lpe.aDomain := aDomain;
|
|
lpe.aFlags := aFlags;
|
|
//
|
|
lpeEv := lpe;
|
|
fPool.QueueItem(lpeEv);
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.HandleEvent_ResolveServiceResult(
|
|
aHandle: TROHubBytes; aName, aType, aDomain, aLocalAddress: Unicodestring;
|
|
aPort: integer; aText: TROHubBytes);
|
|
var
|
|
lHandle: TObject;
|
|
lHandleVal: string;
|
|
lpe: TROHubPooledEvent;
|
|
lpeEv : IROThreadPoolCallback;
|
|
begin
|
|
lHandle := nil;
|
|
lHandleVal := HandleToString(aHandle);
|
|
fHandles.TryGetValue(lHandleVal, lHandle);
|
|
|
|
if lHandle <> nil then begin
|
|
lpe := TROHubPooledEvent.Create(TROZeroConfHandle(lHandle));
|
|
//
|
|
lpe.aName := aName;
|
|
lpe.aType := aType;
|
|
lpe.aDomain := aDomain;
|
|
lpe.aLocalAddress := aLocalAddress;
|
|
lpe.aPort := aPort;
|
|
lpe.aText := aText;
|
|
//
|
|
lpeEv := lpe;
|
|
fPool.QueueItem(lpeEv);
|
|
end;
|
|
end;
|
|
|
|
function TZeroConfHubClient.QueryInterface(const IID: TGUID;
|
|
out Obj): HResult;
|
|
begin
|
|
if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE
|
|
end;
|
|
|
|
function TZeroConfHubClient.RegisterService(const aName, aService, aDomain: UnicodeString;
|
|
const aFlags: integer; const aHost: Unicodestring; const aPort: integer; const aText: TROHubBytes;
|
|
const aUserData: Pointer; const aDelegate: TROZeroConfRegistrationResult): String;
|
|
var
|
|
lService, lDomain: UnicodeString;
|
|
lArgs: TKeyValuePair;
|
|
zc: TROServiceSetup;
|
|
ldelegate:MulticastDelegate;
|
|
begin
|
|
lService := RemoveLastDot(aService);
|
|
lDomain := RemoveLastDot(aDomain);
|
|
SetLength(lArgs, 7);
|
|
lArgs[0].ArgName := 'aName'; lArgs[0].ArgValue := UnicodeStringToBytes(aName);
|
|
lArgs[1].ArgName := 'aService'; lArgs[1].ArgValue := UnicodeStringToBytes(lService);
|
|
lArgs[2].ArgName := 'aDomain'; lArgs[2].ArgValue := UnicodeStringToBytes(lDomain);
|
|
lArgs[3].ArgName := 'aFlags'; lArgs[3].ArgValue := Int32ToBuffer(aFlags);
|
|
lArgs[4].ArgName := 'aHost'; lArgs[4].ArgValue := UnicodeStringToBytes(aHost);
|
|
lArgs[5].ArgName := 'aPort'; lArgs[5].ArgValue := Int32ToBuffer(aPort);
|
|
lArgs[6].ArgName := 'aText'; lArgs[6].ArgValue := aText;
|
|
ldelegate.aType := zcRegistration;
|
|
ldelegate.RegistrationResult := aDelegate;
|
|
zc := TROServiceSetup.Create(Self, aUserData, ldelegate);
|
|
try
|
|
fWorker.SendData(EncodePackage('RegisterService', true, Int32ToBuffer(zc.GenID), lArgs));
|
|
Result := zc.GetResult;
|
|
finally
|
|
zc.Free;
|
|
end;
|
|
end;
|
|
|
|
function TZeroConfHubClient.ResolveAddress(const aFullName: UnicodeString; const aUserData: Pointer;
|
|
const aDelegate: TROZeroConfResolveAddressResult):String;
|
|
var
|
|
lArgs: TKeyValuePair;
|
|
zc: TROServiceSetup;
|
|
ldelegate: MulticastDelegate;
|
|
begin
|
|
SetLength(lArgs,1);
|
|
lArgs[0].ArgName := 'aFullName';lArgs[0].ArgValue := UnicodeStringToBytes(aFullName);
|
|
ldelegate.aType := zcResolveAddress;
|
|
ldelegate.ResolveAddressResult := aDelegate;
|
|
zc := TROServiceSetup.Create(Self, aUserData, ldelegate);
|
|
try
|
|
fWorker.SendData(EncodePackage('ResolveAddress', true, Int32ToBuffer(zc.GenID), lArgs));
|
|
Result := zc.GetResult;
|
|
finally
|
|
zc.Free;
|
|
end;
|
|
end;
|
|
|
|
function TZeroConfHubClient.ResolveService(const aServiceName, aServiceType, aDomain: UnicodeString;
|
|
const aUserData: Pointer; const aDelegate: TROZeroConfResolveServiceResult):String;
|
|
var
|
|
lServiceType,lDomain: UnicodeString;
|
|
lArgs: TKeyValuePair;
|
|
zc: TROServiceSetup;
|
|
ldelegate: MulticastDelegate;
|
|
begin
|
|
lServiceType := RemoveLastDot(aServiceType);
|
|
lDomain := RemoveLastDot(aDomain);
|
|
SetLength(lArgs,3);
|
|
lArgs[0].ArgName := 'aName'; lArgs[0].ArgValue := UnicodeStringToBytes(aServiceName);
|
|
lArgs[1].ArgName := 'aType'; lArgs[1].ArgValue := UnicodeStringToBytes(lServiceType);
|
|
lArgs[2].ArgName := 'aDomain'; lArgs[2].ArgValue := UnicodeStringToBytes(lDomain);
|
|
ldelegate.aType := zcResolveService;
|
|
ldelegate.ResolveServiceResult := aDelegate;
|
|
zc := TROServiceSetup.Create(Self, aUserData, ldelegate);
|
|
try
|
|
fWorker.SendData(EncodePackage('ResolveService', true, Int32ToBuffer(zc.GenID), lArgs));
|
|
Result := zc.GetResult;
|
|
finally
|
|
zc.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.SendCommand_CloseHandle(aHandle: TROHubBytes);
|
|
var
|
|
lArgs: TKeyValuePair;
|
|
wr: TROWaitingRequest;
|
|
lGenID: integer;
|
|
lOk: Boolean;
|
|
begin
|
|
lOk := True;
|
|
SetLength(lArgs,1);
|
|
lArgs[0].ArgName := 'aHandle';
|
|
lArgs[0].ArgValue := aHandle;
|
|
wr := TROWaitingRequest.Create(True);
|
|
try
|
|
lGenID := fWorker.GenerateID(true);
|
|
fWaitingRequests.Add(lGenID, wr);
|
|
fWorker.SendData(EncodePackage('CloseHandle', true, Int32ToBuffer(lGenID), lArgs));
|
|
// lOk := wr.Event.WaitFor(fCommandTimeout) = wrSignaled;// in ms
|
|
fWaitingRequests.Remove(lGenID);
|
|
if (not lOk) then raise EROZeroConfHubException.Create('Timeout waiting for request', 0);
|
|
if EndsWith('#Exception', wr.Name, True) then ProcessException(wr.Args);
|
|
finally
|
|
SetLength(lArgs,0);
|
|
wr.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.Start;
|
|
var
|
|
lSock: TTCPStream;
|
|
begin
|
|
if (fWorker = nil) then begin
|
|
lSock := CreateTCPClient;
|
|
fWorker := TROStreamWorker.Create(Self,lSock);
|
|
lSock.Connect(HUB_HOST, HUB_PORT);
|
|
fWorker.Start();
|
|
end;
|
|
end;
|
|
|
|
procedure TZeroConfHubClient.Stop;
|
|
begin
|
|
if fWorker <> nil then begin
|
|
CloseHandles;
|
|
FreeAndNil(fWorker);
|
|
end;
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'TROServiceSetup methods'}{$ENDIF DELPHI10UP}
|
|
function TZeroConfHubClient._AddRef: Integer;
|
|
begin
|
|
Result := -1 // -1 indicates no reference counting is taking place
|
|
end;
|
|
|
|
function TZeroConfHubClient._Release: Integer;
|
|
begin
|
|
Result := -1 // -1 indicates no reference counting is taking place
|
|
end;
|
|
|
|
destructor TROHubPooledEvent.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
{ TROServiceSetup }
|
|
|
|
constructor TROServiceSetup.Create(aOwner: TZeroConfHubClient; aUserData: Pointer; aDelegate: MulticastDelegate);
|
|
begin
|
|
inherited Create;
|
|
fOwner := aOwner;
|
|
fWaitHandle := TROEvent.Create(nil,false,false,'');
|
|
fWaitingRequest := TROWaitingRequest.Create;
|
|
fWaitingRequest.Trigger := Self.Trigger;
|
|
fHandle := TROZeroConfHandle.Create;
|
|
fHandle.UserData := aUserData;
|
|
fHandle.Delegate := aDelegate;
|
|
fGenID := fOwner.fWorker.GenerateID(true);
|
|
fOwner.fWaitingRequests.Add(fGenID, fWaitingRequest);
|
|
end;
|
|
|
|
destructor TROServiceSetup.Destroy;
|
|
begin
|
|
FreeAndNil(fWaitingRequest);
|
|
// FreeAndNil(fHandle);
|
|
inherited;
|
|
end;
|
|
|
|
function TROServiceSetup.GetResult: String;
|
|
var
|
|
lOk: Boolean;
|
|
begin
|
|
lOk := fWaitHandle.WaitFor(fOwner.fCommandTimeout)=wrSignaled; // in ms
|
|
FreeAndNil(fWaitHandle);
|
|
fOwner.fWaitingRequests.Remove(fGenID);
|
|
if ( not lOk) then raise EROZeroConfHubException.Create('Timeout waiting for request', 0);
|
|
if EndsWith('#Exception',fWaitingRequest.Name,True) then ProcessException(fWaitingRequest.Args);
|
|
Result := fHandleVal;
|
|
end;
|
|
|
|
procedure TROServiceSetup.Trigger;
|
|
begin
|
|
try
|
|
if not EndsWith('#Exception',fWaitingRequest.Name) then begin
|
|
fHandle.Handle := FindParameter(fWaitingRequest.Args, 'aHandle');
|
|
fHandleVal := HandleToString(fHandle.Handle);
|
|
fOwner.fHandles.Add(fHandleVal, fHandle);
|
|
end
|
|
else begin
|
|
FreeAndNil(fHandle);
|
|
end;
|
|
if fWaitHandle <> nil then fWaitHandle.SetEvent;
|
|
except
|
|
fWaitingRequest.Name := '#Exception';
|
|
fOwner.fHandles.Remove(fHandleVal);
|
|
FreeAndNil(fHandle);
|
|
end;
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'TRODictionary methods'}{$ENDIF DELPHI10UP}
|
|
{ TRODictionary }
|
|
|
|
procedure TRODictionary.Add(aKey: string; aValue: TObject);
|
|
begin
|
|
Lock;
|
|
try
|
|
FItems.AddObject(aKey,aValue);
|
|
finally
|
|
Unlock;
|
|
end;
|
|
end;
|
|
|
|
procedure TRODictionary.Add(aKey: integer; aValue: TObject);
|
|
begin
|
|
Add(IntToStr(aKey),aValue);
|
|
end;
|
|
|
|
constructor TRODictionary.Create;
|
|
begin
|
|
inherited;
|
|
{$IFDEF FPC}
|
|
InitCriticalSection(FLock);
|
|
{$ELSE}
|
|
InitializeCriticalSection(FLock);
|
|
{$ENDIF}
|
|
fItems := TStringList.Create;
|
|
fItems.Duplicates:= dupError;
|
|
end;
|
|
|
|
destructor TRODictionary.Destroy;
|
|
begin
|
|
Lock;
|
|
try
|
|
fItems.Free;
|
|
inherited;
|
|
finally
|
|
Unlock;
|
|
{$IFDEF FPC}
|
|
DoneCriticalSection(FLock);
|
|
{$ELSE}
|
|
DeleteCriticalSection(FLock);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
function TRODictionary.Lock: TStringList;
|
|
begin
|
|
EnterCriticalSection(FLock);
|
|
Result := fItems;
|
|
end;
|
|
|
|
procedure TRODictionary.Remove(aKey: integer);
|
|
begin
|
|
Remove(IntToStr(aKey));
|
|
end;
|
|
|
|
procedure TRODictionary.Remove(aKey: string);
|
|
var
|
|
i: integer;
|
|
begin
|
|
Lock;
|
|
try
|
|
i := FItems.IndexOf(aKey);
|
|
if i <> -1 then FItems.Delete(i);
|
|
finally
|
|
Unlock;
|
|
end;
|
|
end;
|
|
|
|
function TRODictionary.TryGetValue(aKey: string;
|
|
out aValue: TObject): boolean;
|
|
var
|
|
i: integer;
|
|
begin
|
|
Lock;
|
|
try
|
|
i := FItems.IndexOf(aKey);
|
|
Result := i <> -1;
|
|
if Result then aValue := FItems.Objects[i];
|
|
finally
|
|
Unlock;
|
|
end;
|
|
end;
|
|
|
|
procedure TRODictionary.Unlock;
|
|
begin
|
|
LeaveCriticalSection(FLock);
|
|
end;
|
|
|
|
function TRODictionary.TryGetValue(aKey: integer;
|
|
out aValue: TObject): boolean;
|
|
begin
|
|
Result := TryGetValue(IntToStr(aKey),aValue);
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'TROWaitingRequest methods'}{$ENDIF DELPHI10UP}
|
|
{ TROWaitingRequest }
|
|
|
|
constructor TROWaitingRequest.Create(ACreateWithEventSupport: Boolean = False);
|
|
begin
|
|
inherited Create;
|
|
fName := '';
|
|
SetLength(FArgs,0);
|
|
if ACreateWithEventSupport then begin
|
|
fwh := TROEvent.Create(nil, False,False,'');
|
|
fTrigger := EventTrigger;
|
|
end;
|
|
end;
|
|
|
|
destructor TROWaitingRequest.Destroy;
|
|
begin
|
|
SetLength(FArgs,0);
|
|
fwh.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROWaitingRequest.EventTrigger;
|
|
begin
|
|
fwh.SetEvent;
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
|
|
end.
|