david
2a98435b14
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@68 b6239004-a887-0f4b-9937-50029ccdca16
1727 lines
53 KiB
ObjectPascal
1727 lines
53 KiB
ObjectPascal
unit uROZeroConf;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up, Kylix 2 and up }
|
|
{ platform: Win32, Linux }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ 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
|
|
{$IFDEF MSWINDOWS}Windows,{$ENDIF}
|
|
SysUtils, Classes,
|
|
uROClient,uROServer,uROServerIntf, uROClasses,
|
|
uROmDNS, uROZeroConfHub, uROZeroConfStreamWorker;
|
|
|
|
const
|
|
AllLocalServices = '_services._dns-sd._udp.';
|
|
|
|
type
|
|
TROZeroConfEngine = (zceAuto, zceBonjour, zceROZeroConfHub, zceNone);
|
|
TIpType = (ipkAny, iptIP4, iptIP6);
|
|
TROZeroConfRegistration = class;
|
|
TROZeroConfBrowser = class;
|
|
TROZeroConfService = class;
|
|
|
|
TROBaseZeroConf = class(TROComponent)
|
|
private
|
|
FEngine: TROZeroConfEngine;
|
|
FDomain: Unicodestring;
|
|
function GetHubClientClass(dummy: boolean): TZeroConfHubClientClass;
|
|
procedure SetDomain(const Value: Unicodestring);
|
|
protected
|
|
procedure TriggerFailed(const ACurrentEngine: TROZeroConfEngine;anException: Exception); virtual; abstract;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
published
|
|
property Engine: TROZeroConfEngine read FEngine write FEngine default zceAuto;
|
|
property Domain: Unicodestring read FDomain write SetDomain;
|
|
end;
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'TROZeroConfRegistration'}{$ENDIF DELPHI10UP}
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'IZeroConfRegistrationStrategy'}{$ENDIF DELPHI10UP}
|
|
IZeroConfRegistrationStrategy = interface
|
|
procedure RegisterService(const aDomain, aServiceType, aServiceName: UnicodeString; const aPort: integer; aTxtRecord: AnsiString);
|
|
procedure Stop;
|
|
function GetCurrentEngineType: TROZeroConfEngine;
|
|
end;
|
|
|
|
TBaseZeroConfRegistrationEngine = class(TInterfacedObject,IZeroConfRegistrationStrategy)
|
|
protected
|
|
procedure RegisterService(const aDomain, aServiceType, aServiceName: UnicodeString; const aPort: integer; aTxtRecord: AnsiString); virtual; abstract;
|
|
procedure Stop; virtual; abstract;
|
|
function GetCurrentEngineType: TROZeroConfEngine;virtual; abstract;
|
|
public
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TROZeroConfRegistrationEngine = class
|
|
private
|
|
fRegistrationStrategy: IZeroConfRegistrationStrategy;
|
|
fOwner: TROZeroConfRegistration;
|
|
fDomain, fServiceType, fServiceName: UnicodeString;
|
|
fPort: integer;
|
|
fTxtRecord: AnsiString;
|
|
procedure RegistrationSucceeded;
|
|
procedure RegistrationFailed(anException: Exception);
|
|
function CreateHubStrategy:IZeroConfRegistrationStrategy;
|
|
procedure InternalRegisterService;
|
|
function IsNeedToCreateException: Boolean;
|
|
protected
|
|
procedure RegisterService(const aDomain, aServiceType, aServiceName: UnicodeString; const aPort: integer; aTxtRecord: AnsiString);
|
|
procedure Stop;
|
|
function GetCurrentEngineType: TROZeroConfEngine;
|
|
public
|
|
constructor Create(aOwner: TROZeroConfRegistration);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TROBonjourRegistrationStrategy = class(TBaseZeroConfRegistrationEngine)
|
|
private
|
|
fService : TRORegisterNetService;
|
|
FOwner: TROZeroConfRegistrationEngine;
|
|
procedure RegError(Sender: TRODNSService; anErrorCode: DNSServiceErrorType);
|
|
protected
|
|
procedure RegisterService(const aDomain, aServiceType, aServiceName: UnicodeString; const aPort: integer; aTxtRecord: AnsiString);override;
|
|
procedure Stop;override;
|
|
function GetCurrentEngineType: TROZeroConfEngine;override;
|
|
private
|
|
constructor Create(const AOwner: TROZeroConfRegistrationEngine);
|
|
end;
|
|
|
|
TROHubRegistrationStrategy = class(TBaseZeroConfRegistrationEngine)
|
|
private
|
|
fEngine: TROZeroConfRegistrationEngine;
|
|
fClient: TZeroConfHubClient;
|
|
fHubClientClass: TZeroConfHubClientClass;
|
|
protected
|
|
procedure RegisterService(const aDomain, aServiceType, aServiceName: UnicodeString; const aPort: integer; aTxtRecord: AnsiString);override;
|
|
procedure Stop;override;
|
|
function GetCurrentEngineType: TROZeroConfEngine;override;
|
|
public
|
|
constructor Create(const AEngine: TROZeroConfRegistrationEngine;const AHubClientClass: TZeroConfHubClientClass);
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
TROZeroConfRegistrationFailedEvent = procedure(Sender: TROZeroConfRegistration; const ACurrentEngine: TROZeroConfEngine; anException: Exception) of object;
|
|
TROZeroConfRegistrationSuccessEvent = procedure(Sender: TROZeroConfRegistration; const ACurrentEngine: TROZeroConfEngine) of object;
|
|
|
|
TROZeroConfRegistration = class(TROBaseZeroConf)
|
|
private
|
|
FRegistrationEngine: TROZeroConfRegistrationEngine;
|
|
FTXTRecordData: Unicodestring;
|
|
FServer: TROServer;
|
|
FServerName: UnicodeString;
|
|
FIsRegistrationFailed: Boolean;
|
|
fRegistrationFailed: TROZeroConfRegistrationFailedEvent;
|
|
fRegistrationSucceeded: TROZeroConfRegistrationSuccessEvent;
|
|
procedure SetServerName(const Value: Unicodestring);
|
|
procedure SetServer(const Value: TROServer);
|
|
procedure BuildServerChannelTXTRecord(aServer: TROServer);
|
|
procedure RegisterServices(ClassFactory: IROClassFactory; aServer: TROServer);
|
|
procedure RegisterAllServices(aServer: TROServer);
|
|
Procedure ROServer_AfterOpen(Value: TObject);
|
|
Procedure ROServer_BeforeClose(Value: TObject);
|
|
procedure TriggerServiceRegistrationSucceeded(const ACurrentEngine: TROZeroConfEngine);
|
|
protected
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
procedure TriggerFailed(const ACurrentEngine: TROZeroConfEngine;anException: Exception); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
public
|
|
property ServerName: UnicodeString read FServerName write SetServerName;
|
|
procedure Assign(Source: TPersistent); override;
|
|
published
|
|
property Server: TROServer read FServer write SetServer;
|
|
property IsRegistrationFailed: Boolean read FIsRegistrationFailed default False;
|
|
property RegistrationFailed: TROZeroConfRegistrationFailedEvent read fRegistrationFailed write fRegistrationFailed;
|
|
property RegistrationSucceeded: TROZeroConfRegistrationSuccessEvent read fRegistrationSucceeded write fRegistrationSucceeded;
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'TROZeroConfBrowser'}{$ENDIF DELPHI10UP}
|
|
{$IFDEF DELPHI10UP}{$REGION 'IZeroConfBrowseStrategy'}{$ENDIF DELPHI10UP}
|
|
IZeroConfBrowseStrategy = interface
|
|
procedure Start(const aDomain, aServiceType: UnicodeString);
|
|
procedure Stop;
|
|
function GetCurrentEngineType: TROZeroConfEngine;
|
|
end;
|
|
|
|
TBaseZeroConfBrowseStrategy = class(TInterfacedObject, IZeroConfBrowseStrategy)
|
|
protected
|
|
procedure Start(const aDomain, aServiceType: UnicodeString); virtual; abstract;
|
|
procedure Stop; virtual; abstract;
|
|
function GetCurrentEngineType: TROZeroConfEngine; virtual; abstract;
|
|
public
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TROZeroConfBrowseEngine = class
|
|
private
|
|
fBrowseStrategy: IZeroConfBrowseStrategy;
|
|
fDomain, fServiceType: UnicodeString;
|
|
procedure InternalStart;
|
|
function CreateHubStrategy:IZeroConfBrowseStrategy;
|
|
procedure TriggerError(anException: Exception);
|
|
function IsNeedToCreateException: Boolean;
|
|
protected
|
|
fOwner: TROZeroConfBrowser;
|
|
procedure Start(const aDomain, aServiceType: UnicodeString);
|
|
procedure Stop;
|
|
function GetCurrentEngineType: TROZeroConfEngine;
|
|
procedure TriggerBrowse(const Add: boolean; const AServiceName, aServiceType, aDomain: Unicodestring);virtual;
|
|
procedure InternalTriggerError(anException: Exception);virtual;
|
|
public
|
|
constructor Create(aOwner: TROZeroConfBrowser); virtual;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TROBonjourBrowseStrategy = class(TBaseZeroConfBrowseStrategy)
|
|
private
|
|
fBrowse: TROBrowseNetService;
|
|
fEngine: TROZeroConfBrowseEngine;
|
|
procedure cbError(Sender: TRODNSService; anErrorCode: DNSServiceErrorType);
|
|
procedure cbBrowse(service: TRONetService; Add: boolean; AName, aType, aDomain: Unicodestring);
|
|
protected
|
|
procedure Start(const aDomain, aServiceType: UnicodeString); override;
|
|
procedure Stop; override;
|
|
function GetCurrentEngineType: TROZeroConfEngine; override;
|
|
public
|
|
constructor Create(aEngine: TROZeroConfBrowseEngine);
|
|
end;
|
|
|
|
TROHubBrowseStrategy = class(TBaseZeroConfBrowseStrategy)
|
|
private
|
|
fEngine: TROZeroConfBrowseEngine;
|
|
fClient: TZeroConfHubClient;
|
|
fHubClientClass: TZeroConfHubClientClass;
|
|
protected
|
|
procedure Start(const aDomain, aServiceType: UnicodeString); override;
|
|
procedure Stop; override;
|
|
function GetCurrentEngineType: TROZeroConfEngine; override;
|
|
private
|
|
constructor Create(const aEngine: TROZeroConfBrowseEngine; const aHubClientClass: TZeroConfHubClientClass);
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
|
|
IZeroConfResolveStrategy = interface
|
|
function TryResolve(aTimeout: integer): Boolean;
|
|
procedure Resolve(aTimeout: integer);
|
|
function GetCurrentEngineType: TROZeroConfEngine;
|
|
end;
|
|
|
|
TROBaseZeroConfResolveStrategy = class(TInterfacedObject,IZeroConfResolveStrategy)
|
|
protected
|
|
function TryResolve(aTimeout: integer): Boolean; virtual; abstract;
|
|
procedure Resolve(aTimeout: integer); virtual; abstract;
|
|
function GetCurrentEngineType: TROZeroConfEngine; virtual; abstract;
|
|
end;
|
|
|
|
TROZeroConfResolveEngine = class
|
|
private
|
|
fConfService: TROZeroConfService;
|
|
fResolveStrategy: IZeroConfResolveStrategy;
|
|
fRaiseException: Boolean;
|
|
fTimeOut: Integer;
|
|
function IntResolve(ADetectEngine: Boolean = False): Boolean;
|
|
function CreateHubStrategy: TROBaseZeroConfResolveStrategy;
|
|
function TriggerError(var aReRaise: Boolean): boolean;
|
|
protected
|
|
function TryResolve(aTimeout: integer): Boolean;
|
|
procedure Resolve(aTimeout: integer);
|
|
function GetCurrentEngineType: TROZeroConfEngine;
|
|
public
|
|
constructor Create(aConfService: TROZeroConfService);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TROBonjourResolveStrategy = class(TROBaseZeroConfResolveStrategy)
|
|
private
|
|
fEngine: TROZeroConfResolveEngine;
|
|
function IntResolve(aTimeout: integer): DNSServiceErrorType;
|
|
protected
|
|
function TryResolve(aTimeout: integer): Boolean; override;
|
|
procedure Resolve(aTimeout: integer); override;
|
|
function GetCurrentEngineType: TROZeroConfEngine; override;
|
|
public
|
|
constructor Create(aEngine: TROZeroConfResolveEngine);
|
|
end;
|
|
|
|
TROHubResolveStrategy = class(TROBaseZeroConfResolveStrategy)
|
|
private
|
|
fEngine: TROZeroConfResolveEngine;
|
|
fClient: TZeroConfHubClient;
|
|
fHubClientClass: TZeroConfHubClientClass;
|
|
function IntResolve(aTimeout: integer): Boolean;
|
|
protected
|
|
function TryResolve(aTimeout: integer): Boolean; override;
|
|
procedure Resolve(aTimeout: integer); override;
|
|
function GetCurrentEngineType: TROZeroConfEngine; override;
|
|
public
|
|
constructor Create(aEngine: TROZeroConfResolveEngine;const AHubClientClass: TZeroConfHubClientClass);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TROZeroConfBrowseAndResolveEngine = class(TROZeroConfBrowseEngine)
|
|
private
|
|
fEvent: TROEvent;
|
|
fFullDomainName: UnicodeString;
|
|
fHostTarget: UnicodeString;
|
|
fPort: integer;
|
|
fTxtRecord: UnicodeString;
|
|
fAddresses: string;
|
|
fIpType : TIpType;
|
|
fError: Boolean;
|
|
FTimeout: integer;
|
|
protected
|
|
function BrowseAndResolve(aTimeout: integer; const aDomain, aServiceType, aHostTarget: UnicodeString;
|
|
out aFullDomainName: UnicodeString; out aPort: integer;out aTxtRecord: UnicodeString; out aAddresses: string; aIpType: TIpType = ipkAny): Boolean;
|
|
procedure TriggerBrowse(const Add: boolean; const AServiceName, aServiceType, aDomain: Unicodestring);override;
|
|
procedure InternalTriggerError(anException: Exception);override;
|
|
public
|
|
constructor Create(aOwner: TROZeroConfBrowser); override;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
|
|
TROZeroConfService = class
|
|
private
|
|
FBrowser: TROZeroConfBrowser;
|
|
FServiceType: UnicodeString;
|
|
FDomain: UnicodeString;
|
|
FServiceName: UnicodeString;
|
|
FDefEngine, FResolvedEngine: TROZeroConfEngine;
|
|
FResolved: Boolean;
|
|
fFullDomainName:UnicodeString;
|
|
FHostTarget:UnicodeString;
|
|
FTextRecord: Ansistring;
|
|
fIpType: integer;
|
|
fPort: cardinal;
|
|
fIP4Address, fIP6Address: string;
|
|
fResolvedIP4, fResolvedIP6: boolean;
|
|
function GetFullDomainName: UnicodeString;
|
|
function GetHostTarget: UnicodeString;
|
|
procedure CheckResolved;
|
|
function GetPort: cardinal;
|
|
function GetTextRecord: UnicodeString;
|
|
function GetAddress: string;
|
|
function GetIP4Address: string;
|
|
function GetIP6Address: string;
|
|
function GetResolvedIP4: boolean;
|
|
function GetResolvedIP6: boolean;
|
|
function GetResolvedEngine: TROZeroConfEngine;
|
|
public
|
|
constructor Create(aBrowser: TROZeroConfBrowser; aDefEngine: TROZeroConfEngine; aDomain, aServiceName, aServiceType: UnicodeString; aIpType: TIpType = ipkAny);
|
|
function TryResolve: boolean; overload;
|
|
function TryResolve(aTimeout: integer): boolean;overload;
|
|
procedure Resolve;overload;
|
|
procedure Resolve(aTimeout: integer);overload;
|
|
property Domain: UnicodeString read FDomain;
|
|
property ServiceName: UnicodeString read FServiceName;
|
|
property ServiceType: UnicodeString read FServiceType;
|
|
property DefEngine: TROZeroConfEngine read FDefEngine;
|
|
property ResolvedEngine : TROZeroConfEngine read GetResolvedEngine;
|
|
property FullDomainName: UnicodeString read GetFullDomainName;
|
|
property HostTarget: UnicodeString read GetHostTarget;
|
|
property TextRecord: UnicodeString read GetTextRecord;
|
|
Property IP4Address: string read GetIP4Address;
|
|
Property IP6Address: string read GetIP6Address;
|
|
property ResolvedIP6: boolean read GetResolvedIP6;
|
|
property ResolvedIP4: boolean read GetResolvedIP4;
|
|
property Port: cardinal read GetPort;
|
|
Property Address: string read GetAddress;
|
|
property Resolved: Boolean read FResolved;
|
|
end;
|
|
|
|
TROZeroConfBrowserError = procedure(Sender: TROZeroConfBrowser; const ACurrentEngine: TROZeroConfEngine; anException: Exception) of object;
|
|
TROZeroConfBrowserResultEvent = procedure(Sender: TROZeroConfBrowser; aRecord:TROZeroConfService) of object;
|
|
|
|
EDNSServiceException = class(Exception)
|
|
private
|
|
fErrorCode:DNSServiceErrorType;
|
|
public
|
|
constructor Create(const Msg :String; const aErrorCode: DNSServiceErrorType);
|
|
property ErrorCode: DNSServiceErrorType read fErrorCode;
|
|
end;
|
|
|
|
TROZeroConfBrowser = class(TROBaseZeroConf)
|
|
private
|
|
fBrowseEngine: TROZeroConfBrowseEngine;
|
|
FServiceType: Unicodestring;
|
|
FActive: Boolean;
|
|
FStreamedActive: Boolean;
|
|
FOnServiceAdded: TROZeroConfBrowserResultEvent;
|
|
FOnServiceRemoved: TROZeroConfBrowserResultEvent;
|
|
FResults: TThreadList;
|
|
//
|
|
FResolveResult: integer;
|
|
FResolveHostTarget : UnicodeString;
|
|
FOnError: TROZeroConfBrowserError;
|
|
//
|
|
procedure SetServiceType(const Value: Unicodestring);
|
|
procedure SetActive(const Value: Boolean);
|
|
procedure Start;
|
|
procedure IntBrowseResult(const ACurrentEngine: TROZeroConfEngine; Add: boolean; AName, aType, aDomain: Unicodestring);
|
|
procedure ClearCache;
|
|
protected
|
|
procedure Loaded; override;
|
|
procedure TriggerFailed(const ACurrentEngine: TROZeroConfEngine; anException: Exception); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Stop;
|
|
function BrowseAndResolve(aTimeout: integer;const AHostTarget: UnicodeString; out fullDomainName: Unicodestring; out port: integer; out txtRecord: unicodestring; out addresses: string; aIpType: TIpType = ipkAny):Boolean;overload;
|
|
function BrowseAndResolve(const AHostTarget: UnicodeString; out fullDomainName: Unicodestring; out port: integer; out txtRecord: unicodestring; out addresses: string; aIpType: TIpType = ipkAny):Boolean;overload;
|
|
procedure Assign(Source: TPersistent); override;
|
|
published
|
|
property Active: Boolean read FActive write SetActive;
|
|
property ServiceType: Unicodestring read FServiceType write SetServiceType;
|
|
property OnError: TROZeroConfBrowserError read FOnError write FOnError;
|
|
property OnServiceAdded: TROZeroConfBrowserResultEvent read FOnServiceAdded write FOnServiceAdded;
|
|
property OnServiceRemoved: TROZeroConfBrowserResultEvent read FOnServiceRemoved write FOnServiceRemoved;
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
implementation
|
|
uses
|
|
DateUtils, uROZeroConfHubSynapse;
|
|
{ TROZeroConfRegistration }
|
|
|
|
procedure TROZeroConfRegistration.Assign(Source: TPersistent);
|
|
var
|
|
lSource: TROZeroConfRegistration;
|
|
begin
|
|
inherited;
|
|
if Source is TROZeroConfRegistration then begin
|
|
lSource := TROZeroConfRegistration(Source);
|
|
|
|
RegistrationFailed := lSource.RegistrationFailed;
|
|
RegistrationSucceeded := lSource.RegistrationSucceeded;
|
|
Server := lSource.Server;
|
|
end;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistration.BuildServerChannelTXTRecord(
|
|
aServer: TROServer);
|
|
|
|
procedure AddValue(aName,aValue: UnicodeString);
|
|
begin
|
|
if FTXTRecordData <>'' then FTXTRecordData:=FTXTRecordData+#13#10;
|
|
FTXTRecordData :=FTXTRecordData+ aName+'='+aValue;
|
|
end;
|
|
|
|
var
|
|
szc: IZeroConfServerChannel;
|
|
i: integer;
|
|
s,s1: UnicodeString;
|
|
begin
|
|
FTXTRecordData := '';
|
|
if aServer <> nil then begin
|
|
AddValue('txtvers','1');
|
|
{$IFNDEF FPC}
|
|
AddValue('rosdk-edition','Delphi');
|
|
{$ELSE}
|
|
{$IFDEF LCL}
|
|
AddValue('rosdk-edition','Lazarus');
|
|
{$ELSE}
|
|
AddValue('rosdk-edition','FreePascal');
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
// AddValue('rosdk-version',???);
|
|
// AddValue('runtime-version',???);
|
|
{$IFDEF MSWINDOWS}
|
|
case Win32Platform of
|
|
VER_PLATFORM_WIN32s : AddValue('platform','Wins');
|
|
VER_PLATFORM_WIN32_WINDOWS : AddValue('platform','Windows');
|
|
VER_PLATFORM_WIN32_NT : AddValue('platform','WinNT');
|
|
else
|
|
// VER_PLATFORM_WIN32_CE = 3;
|
|
AddValue('platform','WinCE');
|
|
end;
|
|
{$ELSE}
|
|
{$IFDEF FPC}
|
|
AddValue('platform',{$I %FPCTARGETOS%});
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
if Supports(aServer,IZeroConfServerChannel, szc) then begin
|
|
case szc.GetServerType of
|
|
rstTCP: AddValue('channel','tcp');
|
|
rstHTTP: AddValue('channel','http');
|
|
rstUDP: AddValue('channel','udp');
|
|
rstSuperHTTP: AddValue('channel','superhttp');
|
|
rstSuperTCP: AddValue('channel','supertcp');
|
|
else
|
|
AddValue('channel','unknown');
|
|
end;
|
|
end;
|
|
if aServer.Dispatchers.Count > 0 then begin
|
|
s:= '';
|
|
for i := 0 to aServer.Dispatchers.Count - 1 do begin
|
|
if s <> '' then s:= s+ ', ';
|
|
s1:= aServer.Dispatchers[i].Message.ClassName;
|
|
s1 := StringReplace(s1, 'Message', '', []);
|
|
s1 := StringReplace(s1, 'TRO', '', []);
|
|
s:= s+ LowerCase(s1);
|
|
end;
|
|
AddValue('messages',s);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
constructor TROZeroConfRegistration.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FIsRegistrationFailed:= False;
|
|
fRegistrationEngine := TROZeroConfRegistrationEngine.Create(self);
|
|
end;
|
|
|
|
destructor TROZeroConfRegistration.Destroy;
|
|
begin
|
|
Server := nil;
|
|
FreeAndNil(FRegistrationEngine);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistration.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited;
|
|
if (Operation = opRemove) and (AComponent=FServer) then Server:=nil;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistration.RegisterAllServices(aServer: TROServer);
|
|
var
|
|
lcfn: IROStrings;
|
|
i: integer;
|
|
begin
|
|
lcfn := GetZeroConfClassFactoryNames;
|
|
for I := 0 to lcfn.Count - 1 do
|
|
RegisterServices(GetClassFactory(lCfn[i]),aServer);
|
|
end;
|
|
{$IFDEF FPC}{$HINTS OFF}{$ENDIF}
|
|
{$IFDEF FPC}{$HINTS ON}{$ENDIF}
|
|
|
|
procedure TROZeroConfRegistration.RegisterServices(
|
|
ClassFactory: IROClassFactory; aServer: TROServer);
|
|
var
|
|
i: integer;
|
|
cfz:IROClassFactory_ZeroConfig;
|
|
sz: IZeroConfServerChannel;
|
|
lPort: integer;
|
|
begin
|
|
if Supports(ClassFactory, IROClassFactory_ZeroConfig, cfz) then begin
|
|
// ServerName := ClassFactory.InterfaceName;
|
|
if Supports(aServer, IZeroConfServerChannel, sz) then lPort:=sz.Port else lPort:=0;
|
|
for I := 0 to cfz.GetAliasNames.Count - 1 do
|
|
fRegistrationEngine.RegisterService(FDomain, cfz.GetAliasNames[i], ServerName, lPort, TXTRecordFromString(FTXTRecordData));
|
|
end;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistration.ROServer_AfterOpen(Value: TObject);
|
|
begin
|
|
if (csDesigning in ComponentState) then Exit;
|
|
BuildServerChannelTXTRecord(TROServer(Value));
|
|
RegisterAllServices(TROServer(Value));
|
|
end;
|
|
|
|
{$IFDEF FPC}{$HINTS OFF}{$ENDIF}
|
|
procedure TROZeroConfRegistration.ROServer_BeforeClose(Value: TObject);
|
|
begin
|
|
fRegistrationEngine.Stop;
|
|
end;
|
|
{$IFDEF FPC}{$HINTS ON}{$ENDIF}
|
|
|
|
procedure TROZeroConfRegistration.SetServer(const Value: TROServer);
|
|
var
|
|
zc: IZeroConfServerChannel;
|
|
ev: TNotifyEvent;
|
|
begin
|
|
if FServer <> Value then begin
|
|
if Assigned(FServer) then begin
|
|
FServer.RORemoveFreeNotification(Self);
|
|
if Supports(FServer, IZeroConfServerChannel,zc) then begin
|
|
zc.Z_SetAfterOpen(nil);
|
|
zc.Z_SetBeforeClose(nil);
|
|
ROServer_BeforeClose(FServer);
|
|
zc.ZeroConfRegistrationServer := nil;
|
|
end;
|
|
end;
|
|
FServer := nil;
|
|
if Value <> nil then begin
|
|
if Supports(Value, IZeroConfServerChannel,zc) then begin
|
|
if (zc.ZeroConfRegistrationServer <> nil) then
|
|
raise Exception.CreateFmt('%s cannot be used with %s because it is already linked with %s ',[Self.Name, Server.Name, TROZeroConfRegistration(zc.ZeroConfRegistrationServer).Name]);
|
|
FServer := Value;
|
|
FServer.ROFreeNotification(Self);
|
|
zc.ZeroConfRegistrationServer:=Self;
|
|
if FServer.Active then ROServer_AfterOpen(FServer);
|
|
ev := ROServer_AfterOpen;
|
|
zc.Z_SetAfterOpen(ev);
|
|
ev := ROServer_BeforeClose;
|
|
zc.Z_SetBeforeClose(ev);
|
|
end
|
|
else begin
|
|
raise Exception.Create(Value.Name + ' does not compatible with '+ClassName);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TROZeroConfRegistration.SetServerName(const Value: Unicodestring);
|
|
begin
|
|
FServerName := Value;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistration.TriggerFailed(const ACurrentEngine: TROZeroConfEngine;anException: Exception);
|
|
begin
|
|
fIsRegistrationFailed := true;
|
|
if Assigned(fRegistrationFailed) then fRegistrationFailed(self,ACurrentEngine, anException);
|
|
end;
|
|
|
|
procedure TROZeroConfRegistration.TriggerServiceRegistrationSucceeded(const ACurrentEngine: TROZeroConfEngine);
|
|
begin
|
|
fIsRegistrationFailed := false;
|
|
if Assigned(fRegistrationSucceeded) then fRegistrationSucceeded(self, ACurrentEngine);
|
|
end;
|
|
|
|
{ TROZeroConfBrowser }
|
|
|
|
function TROZeroConfBrowser.BrowseAndResolve(aTimeout: integer;
|
|
const AHostTarget: UnicodeString; out fullDomainName: Unicodestring;
|
|
out port: integer; out txtRecord: unicodestring; out addresses: string; aIpType: TIpType = ipkAny): Boolean;
|
|
var
|
|
lBrowseAndResolveEngine: TROZeroConfBrowseAndResolveEngine;
|
|
begin
|
|
FResolveResult := 0;
|
|
FResolveHostTarget := AHostTarget;
|
|
if not EndsWith(FDomain, FResolveHostTarget) then FResolveHostTarget := FResolveHostTarget +'.' +FDomain;
|
|
lBrowseAndResolveEngine := TROZeroConfBrowseAndResolveEngine.Create(Self);
|
|
try
|
|
Result := lBrowseAndResolveEngine.BrowseAndResolve(aTimeout, FDomain, FServiceType, FResolveHostTarget, fullDomainName, port, txtRecord, addresses, aIpType);
|
|
finally
|
|
FreeAndNil(lBrowseAndResolveEngine);
|
|
end;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowser.Assign(Source: TPersistent);
|
|
var
|
|
lSource: TROZeroConfBrowser;
|
|
begin
|
|
if Active then raise EROException.Create( Self.Name+' must be stopped before assigning');
|
|
inherited;
|
|
if Source is TROZeroConfBrowser then begin
|
|
lSource := TROZeroConfBrowser(Source);
|
|
|
|
OnError := lSource.OnError;
|
|
OnServiceAdded := lSource.OnServiceAdded;
|
|
OnServiceRemoved := lSource.OnServiceRemoved;
|
|
ServiceType := lSource.ServiceType;
|
|
end;
|
|
end;
|
|
|
|
function TROZeroConfBrowser.BrowseAndResolve(const AHostTarget: UnicodeString;
|
|
out fullDomainName: Unicodestring; out port: integer; out txtRecord: unicodestring;
|
|
out addresses: string; aIpType: TIpType = ipkAny): Boolean;
|
|
begin
|
|
Result:= BrowseAndResolve(15, AHostTarget, fullDomainName, port, txtRecord, addresses, aIpType);
|
|
end;
|
|
|
|
procedure TROZeroConfBrowser.ClearCache;
|
|
begin
|
|
With FResults.LockList do try
|
|
while Count > 0 do begin
|
|
TObject(Items[0]).Free;
|
|
Delete(0);
|
|
end;
|
|
finally
|
|
FResults.UnlockList;
|
|
end;
|
|
end;
|
|
|
|
constructor TROZeroConfBrowser.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FResults := TThreadList.Create;
|
|
FServiceType := AllLocalServices;
|
|
fBrowseEngine := TROZeroConfBrowseEngine.Create(Self);
|
|
end;
|
|
|
|
destructor TROZeroConfBrowser.Destroy;
|
|
begin
|
|
Stop;
|
|
FreeAndNil(fBrowseEngine);
|
|
FResults.Free;
|
|
inherited;
|
|
end;
|
|
|
|
{$IFDEF FPC}{$HINTS OFF}{$ENDIF}
|
|
|
|
procedure TROZeroConfBrowser.IntBrowseResult(const ACurrentEngine: TROZeroConfEngine; Add: boolean; AName, aType, aDomain: Unicodestring);
|
|
var
|
|
lRes: TROZeroConfService;
|
|
i: integer;
|
|
begin
|
|
lRes := nil;
|
|
with FResults.LockList do try
|
|
for I := 0 to Count - 1 do
|
|
with TROZeroConfService(Items[i]) do
|
|
if (ServiceType = aType) and (Domain = aDomain) and (ServiceName = AName) and
|
|
(DefEngine = ACurrentEngine) then begin
|
|
lRes := TROZeroConfService(Items[i]);
|
|
Break;
|
|
end;
|
|
finally
|
|
FResults.UnlockList;
|
|
end;
|
|
if Add then begin
|
|
if lRes <> nil then Exit;
|
|
lRes := TROZeroConfService.Create(Self, ACurrentEngine,aDomain, AName, aType);
|
|
FResults.Add(lRes);
|
|
if Assigned(onServiceAdded) then onServiceAdded(Self,lRes);
|
|
end
|
|
else begin
|
|
if lRes <> nil then begin
|
|
FResults.Remove(lRes);
|
|
try
|
|
if Assigned(onServiceRemoved) then onServiceRemoved(Self,lRes);
|
|
finally
|
|
lRes.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
{$IFDEF FPC}{$HINTS ON}{$ENDIF}
|
|
|
|
procedure TROZeroConfBrowser.Loaded;
|
|
begin
|
|
inherited;
|
|
if fStreamedActive then Active:=True;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowser.SetActive(const Value: Boolean);
|
|
begin
|
|
if csLoading in ComponentState then begin
|
|
fStreamedActive := Value
|
|
end
|
|
else if FActive <> Value then begin
|
|
FActive := Value;
|
|
if (csDesigning in ComponentState) then Exit;
|
|
if Value then Start else Stop;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
procedure TROZeroConfBrowser.SetServiceType(const Value: Unicodestring);
|
|
begin
|
|
FServiceType := Value;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowser.Start;
|
|
begin
|
|
fBrowseEngine.Start(FDomain, FServiceType);
|
|
fActive := True;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowser.Stop;
|
|
begin
|
|
if (fBrowseEngine <> nil) then fBrowseEngine.Stop;
|
|
fActive := False;
|
|
ClearCache;
|
|
end;
|
|
|
|
|
|
procedure TROZeroConfBrowser.TriggerFailed(
|
|
const ACurrentEngine: TROZeroConfEngine; anException: Exception);
|
|
begin
|
|
if Assigned(fOnError) then FOnError(Self, ACurrentEngine, anException);
|
|
end;
|
|
|
|
{ TROZeroConfService }
|
|
|
|
procedure TROZeroConfService.CheckResolved;
|
|
begin
|
|
if (not fResolved) then raise Exception.Create('Not resolved yet');
|
|
end;
|
|
|
|
constructor TROZeroConfService.Create(aBrowser: TROZeroConfBrowser; aDefEngine: TROZeroConfEngine; aDomain, aServiceName, aServiceType: UnicodeString; aIpType: TIpType = ipkAny);
|
|
begin
|
|
inherited Create;
|
|
fBrowser := aBrowser;
|
|
FServiceType := aServiceType;
|
|
FDomain := aDomain;
|
|
FServiceName := aServiceName;
|
|
fDefEngine := aDefEngine;
|
|
case aIpType of
|
|
iptIP4: fIpType := AF_INET;
|
|
iptIP6: fIpType := AF_INET6;
|
|
else
|
|
fIpType := AF_UNSPEC;
|
|
end;
|
|
end;
|
|
|
|
function TROZeroConfService.GetAddress: string;
|
|
begin
|
|
CheckResolved;
|
|
Result := fIP6Address;
|
|
if (Result = '') or (fIpType <> AF_INET6) then
|
|
Result := fIP4Address;
|
|
end;
|
|
|
|
function TROZeroConfService.GetFullDomainName: UnicodeString;
|
|
begin
|
|
CheckResolved;
|
|
Result := fFullDomainName;
|
|
end;
|
|
|
|
function TROZeroConfService.GetHostTarget: UnicodeString;
|
|
begin
|
|
CheckResolved;
|
|
Result := FHostTarget;
|
|
end;
|
|
|
|
function TROZeroConfService.GetIP4Address: string;
|
|
begin
|
|
CheckResolved;
|
|
Result := FIP4Address;
|
|
end;
|
|
|
|
function TROZeroConfService.GetIP6Address: string;
|
|
begin
|
|
CheckResolved;
|
|
Result := FIP6Address;
|
|
end;
|
|
|
|
function TROZeroConfService.GetPort: cardinal;
|
|
begin
|
|
CheckResolved;
|
|
Result := fPort;
|
|
end;
|
|
|
|
|
|
function TROZeroConfService.GetResolvedEngine: TROZeroConfEngine;
|
|
begin
|
|
CheckResolved;
|
|
Result := FResolvedEngine;
|
|
end;
|
|
|
|
function TROZeroConfService.GetResolvedIP4: boolean;
|
|
begin
|
|
CheckResolved;
|
|
Result := fResolvedIP4;
|
|
end;
|
|
|
|
function TROZeroConfService.GetResolvedIP6: boolean;
|
|
begin
|
|
CheckResolved;
|
|
Result := fResolvedIP6;
|
|
end;
|
|
|
|
function TROZeroConfService.GetTextRecord: UnicodeString;
|
|
begin
|
|
CheckResolved;
|
|
Result := StringFromTXTRecord(FTextRecord);
|
|
end;
|
|
|
|
procedure TROZeroConfService.Resolve;
|
|
begin
|
|
Resolve(10);
|
|
end;
|
|
|
|
procedure TROZeroConfService.Resolve(aTimeout: integer);
|
|
var
|
|
lEngine : TROZeroConfResolveEngine;
|
|
begin
|
|
lEngine := TROZeroConfResolveEngine.Create(Self);
|
|
try
|
|
lEngine.Resolve(aTimeout);
|
|
finally
|
|
FreeAndNil(lEngine);
|
|
end;
|
|
end;
|
|
|
|
function TROZeroConfService.TryResolve(aTimeout: integer): boolean;
|
|
var
|
|
lEngine : TROZeroConfResolveEngine;
|
|
begin
|
|
lEngine := TROZeroConfResolveEngine.Create(Self);
|
|
try
|
|
Result := lEngine.TryResolve(aTimeout);
|
|
finally
|
|
FreeAndNil(lEngine);
|
|
end;
|
|
end;
|
|
|
|
function TROZeroConfService.TryResolve: boolean;
|
|
begin
|
|
result := TryResolve(10);
|
|
end;
|
|
|
|
{ EDNSServiceException }
|
|
|
|
constructor EDNSServiceException.Create(const Msg :String; const aErrorCode: DNSServiceErrorType);
|
|
begin
|
|
inherited Create(Msg);
|
|
FErrorCode := aErrorCode;
|
|
end;
|
|
|
|
{ TROBaseZeroConf }
|
|
|
|
function TROBaseZeroConf.GetHubClientClass(dummy: boolean): TZeroConfHubClientClass;
|
|
begin
|
|
Result := TZeroConfHubSynapseClient;
|
|
end;
|
|
|
|
procedure TROBaseZeroConf.Assign(Source: TPersistent);
|
|
var
|
|
lSource: TROBaseZeroConf;
|
|
begin
|
|
inherited;
|
|
if Source is TROBaseZeroConf then begin
|
|
lSource := TROBaseZeroConf(Source);
|
|
|
|
Domain := lSource.Domain;
|
|
Engine := lSource.Engine;
|
|
end;
|
|
end;
|
|
|
|
constructor TROBaseZeroConf.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FEngine := zceAuto;
|
|
end;
|
|
|
|
destructor TROBaseZeroConf.Destroy;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROBaseZeroConf.SetDomain(const Value: Unicodestring);
|
|
begin
|
|
FDomain := Value;
|
|
if (FDomain <> '') and (FDomain[Length(FDomain)] <> '.') then FDomain := FDomain+'.'
|
|
end;
|
|
|
|
{$IFDEF DELPHI10UP}{$REGION 'IZeroConfRegistrationStrategy'}{$ENDIF DELPHI10UP}
|
|
{ TROZeroConfRegistrationEngine }
|
|
|
|
constructor TROZeroConfRegistrationEngine.Create(aOwner: TROZeroConfRegistration);
|
|
begin
|
|
inherited Create;
|
|
fOwner := aOwner;
|
|
end;
|
|
|
|
function TROZeroConfRegistrationEngine.CreateHubStrategy: IZeroConfRegistrationStrategy;
|
|
var
|
|
lClientClass: TZeroConfHubClientClass;
|
|
begin
|
|
lClientClass := fOwner.GetHubClientClass(fOwner.Engine = zceROZeroConfHub);
|
|
if Assigned(lClientClass) then
|
|
Result := TROHubRegistrationStrategy.Create(Self, lClientClass)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
destructor TROZeroConfRegistrationEngine.Destroy;
|
|
begin
|
|
Stop;
|
|
inherited;
|
|
end;
|
|
|
|
function TROZeroConfRegistrationEngine.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
if fRegistrationStrategy <> nil then
|
|
Result := fRegistrationStrategy.GetCurrentEngineType
|
|
else
|
|
Result := fOwner.Engine;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistrationEngine.InternalRegisterService;
|
|
begin
|
|
if fRegistrationStrategy = nil then Exit;
|
|
try
|
|
fRegistrationStrategy.RegisterService(fDomain, fServiceType, fServiceName, fPort, fTxtRecord);
|
|
except
|
|
on E: Exception do begin
|
|
RegistrationFailed(E);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROZeroConfRegistrationEngine.IsNeedToCreateException: Boolean;
|
|
begin
|
|
Result :=
|
|
not ((fRegistrationStrategy.GetCurrentEngineType = zceBonjour) and
|
|
(fOwner.Engine = zceAuto) and
|
|
Assigned(fOwner.GetHubClientClass(False)));
|
|
end;
|
|
|
|
procedure TROZeroConfRegistrationEngine.RegisterService(const aDomain,
|
|
aServiceType, aServiceName: UnicodeString; const aPort: integer;
|
|
aTxtRecord: AnsiString);
|
|
var
|
|
lEngine: TROZeroConfEngine;
|
|
begin
|
|
fDomain:= aDomain;
|
|
fServiceType := aServiceType;
|
|
fServiceName := aServiceName;
|
|
fPort := aPort;
|
|
fTxtRecord := aTxtRecord;
|
|
|
|
fRegistrationStrategy := nil;
|
|
|
|
|
|
lEngine := fOwner.Engine;
|
|
|
|
if lEngine = zceAuto then begin
|
|
if CheckDNSFunctions(False) then // Bonjour is present
|
|
lEngine := zceBonjour
|
|
else if fOwner.GetHubClientClass(False) <> nil then // Hub is present
|
|
lEngine := zceROZeroConfHub
|
|
else try // bonjour and hub isn't present
|
|
CheckDNSFunctions(True);
|
|
except
|
|
On E: Exception do begin
|
|
RegistrationFailed(E);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
case lEngine of
|
|
zceBonjour: fRegistrationStrategy := TROBonjourRegistrationStrategy.Create(self);
|
|
zceROZeroConfHub: fRegistrationStrategy := CreateHubStrategy;
|
|
zceNone: ;
|
|
end;
|
|
InternalRegisterService;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistrationEngine.RegistrationFailed(anException: Exception);
|
|
begin
|
|
if Assigned(fRegistrationStrategy) and
|
|
(fRegistrationStrategy.GetCurrentEngineType = zceBonjour) and
|
|
(fOwner.Engine = zceAuto) and
|
|
Assigned(fOwner.GetHubClientClass(False)) then begin
|
|
fRegistrationStrategy := CreateHubStrategy;
|
|
InternalRegisterService;
|
|
end
|
|
else begin
|
|
try
|
|
fOwner.TriggerFailed(GetCurrentEngineType, anException);
|
|
finally
|
|
Stop;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROZeroConfRegistrationEngine.RegistrationSucceeded;
|
|
begin
|
|
fOwner.TriggerServiceRegistrationSucceeded(GetCurrentEngineType);
|
|
end;
|
|
|
|
procedure TROZeroConfRegistrationEngine.Stop;
|
|
begin
|
|
if fRegistrationStrategy <> nil then begin
|
|
fRegistrationStrategy.Stop;
|
|
fRegistrationStrategy := nil;
|
|
end;
|
|
end;
|
|
|
|
{ TROBonjourRegistrationStrategy }
|
|
|
|
constructor TROBonjourRegistrationStrategy.Create(
|
|
const AOwner: TROZeroConfRegistrationEngine);
|
|
begin
|
|
inherited Create;
|
|
FOwner := AOwner;
|
|
end;
|
|
|
|
function TROBonjourRegistrationStrategy.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
Result := zceBonjour;
|
|
end;
|
|
|
|
procedure TROBonjourRegistrationStrategy.RegError(Sender: TRODNSService;
|
|
anErrorCode: DNSServiceErrorType);
|
|
begin
|
|
if anErrorCode = kDNSServiceErr_NoError then
|
|
FOwner.RegistrationSucceeded
|
|
else begin
|
|
if not FOwner.IsNeedToCreateException then FOwner.RegistrationFailed(nil)
|
|
else try
|
|
TRORegisterNetService.CreateDNSServiceRegisterException(anErrorCode);
|
|
except
|
|
on E: Exception do FOwner.RegistrationFailed(E);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROBonjourRegistrationStrategy.RegisterService(const aDomain,
|
|
aServiceType, aServiceName: UnicodeString; const aPort: integer;
|
|
aTxtRecord: AnsiString);
|
|
begin
|
|
Stop;
|
|
fService := TRORegisterNetService.Create(aDomain, aServiceType, aServiceName, aPort);
|
|
fService.TXTRecordData := aTxtRecord;
|
|
fService.OnError := RegError;
|
|
fService.Publish;
|
|
end;
|
|
|
|
procedure TROBonjourRegistrationStrategy.Stop;
|
|
begin
|
|
FreeAndNil(fService);
|
|
end;
|
|
|
|
{ TROHubRegistrationStrategy }
|
|
|
|
constructor TROHubRegistrationStrategy.Create(const AEngine: TROZeroConfRegistrationEngine;const AHubClientClass: TZeroConfHubClientClass);
|
|
begin
|
|
inherited Create;
|
|
fEngine:= AEngine;
|
|
FHubClientClass := AHubClientClass;
|
|
end;
|
|
|
|
procedure RegistrationResult(aHandle: String; aUserData: Pointer; aName, aService, aDomain: UnicodeString; anErrorCode: integer);
|
|
begin
|
|
if Assigned(aUserData) then begin
|
|
with TROHubRegistrationStrategy(aUserData) do begin
|
|
if anErrorCode = 0 then
|
|
fEngine.RegistrationSucceeded
|
|
else begin
|
|
if not fEngine.IsNeedToCreateException then fEngine.RegistrationFailed(nil)
|
|
else try
|
|
raise EROZeroConfHubException.CreateFmt('Registration failed. ErrorCode = %d',[anErrorCode],anErrorCode);
|
|
except
|
|
on E: Exception do fEngine.RegistrationFailed(E);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROHubRegistrationStrategy.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
Result := zceROZeroConfHub;
|
|
end;
|
|
|
|
procedure TROHubRegistrationStrategy.RegisterService(const aDomain,
|
|
aServiceType, aServiceName: UnicodeString; const aPort: integer;
|
|
aTxtRecord: AnsiString);
|
|
var
|
|
lCallcack : TROZeroConfRegistrationResult;
|
|
begin
|
|
lCallcack := RegistrationResult;
|
|
if fClient = nil then begin
|
|
fClient := fHubClientClass.Create;
|
|
try
|
|
fClient.Start;
|
|
except
|
|
FreeAndNil(fClient);
|
|
raise;
|
|
end;
|
|
end;
|
|
fClient.RegisterService(aServiceName,aServiceType,aDomain,0, '', aPort, aTxtRecord, Self, lCallcack);
|
|
end;
|
|
|
|
procedure TROHubRegistrationStrategy.Stop;
|
|
begin
|
|
FreeAndnil(fClient);
|
|
end;
|
|
{$IFDEF DELPHI10UP}{$ENDREGION}{$ENDIF DELPHI10UP}
|
|
|
|
{ TBaseZeroConfRegistrationEngine }
|
|
|
|
destructor TBaseZeroConfRegistrationEngine.Destroy;
|
|
begin
|
|
Stop;
|
|
inherited;
|
|
end;
|
|
|
|
{ TBaseZeroConfBrowseStrategy }
|
|
|
|
destructor TBaseZeroConfBrowseStrategy.Destroy;
|
|
begin
|
|
Stop;
|
|
inherited;
|
|
end;
|
|
|
|
{ TROZeroConfBrowseEngine }
|
|
|
|
constructor TROZeroConfBrowseEngine.Create(aOwner: TROZeroConfBrowser);
|
|
begin
|
|
inherited Create;
|
|
FOwner := AOwner;
|
|
end;
|
|
|
|
function TROZeroConfBrowseEngine.CreateHubStrategy: IZeroConfBrowseStrategy;
|
|
var
|
|
lClientClass: TZeroConfHubClientClass;
|
|
begin
|
|
lClientClass := fOwner.GetHubClientClass(fOwner.Engine = zceROZeroConfHub);
|
|
if Assigned(lClientClass) then
|
|
Result := TROHubBrowseStrategy.Create(Self, lClientClass)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
destructor TROZeroConfBrowseEngine.Destroy;
|
|
begin
|
|
Stop;
|
|
inherited;
|
|
end;
|
|
|
|
function TROZeroConfBrowseEngine.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
if fBrowseStrategy = nil then
|
|
Result := fOwner.Engine
|
|
else
|
|
Result := fBrowseStrategy.GetCurrentEngineType;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseEngine.InternalStart;
|
|
begin
|
|
if fBrowseStrategy = nil then Exit;
|
|
try
|
|
fBrowseStrategy.Start(fDomain, fServiceType);
|
|
except
|
|
on E: Exception do TriggerError(E);
|
|
end;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseEngine.InternalTriggerError(
|
|
anException: Exception);
|
|
begin
|
|
fOwner.TriggerFailed(GetCurrentEngineType,anException);
|
|
end;
|
|
|
|
function TROZeroConfBrowseEngine.IsNeedToCreateException: Boolean;
|
|
begin
|
|
Result := not
|
|
((fBrowseStrategy.GetCurrentEngineType = zceBonjour) and
|
|
(fOwner.Engine = zceAuto) and
|
|
Assigned(fOwner.GetHubClientClass(False)));
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseEngine.Start(const aDomain, aServiceType: UnicodeString);
|
|
var
|
|
lEngine: TROZeroConfEngine;
|
|
begin
|
|
fDomain := aDomain;
|
|
fServiceType := aServiceType;
|
|
fBrowseStrategy := nil;
|
|
lEngine := fOwner.Engine;
|
|
|
|
if lEngine = zceAuto then begin
|
|
if CheckDNSFunctions(False) then // Bonjour is present
|
|
lEngine := zceBonjour
|
|
else if fOwner.GetHubClientClass(False) <> nil then // Hub is present
|
|
lEngine := zceROZeroConfHub
|
|
else try // bonjour and hub isn't present
|
|
CheckDNSFunctions(True);
|
|
except
|
|
On E: Exception do begin
|
|
InternalTriggerError(E);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
case lEngine of
|
|
zceBonjour: fBrowseStrategy := TROBonjourBrowseStrategy.Create(self);
|
|
zceROZeroConfHub: fBrowseStrategy := CreateHubStrategy;
|
|
zceNone:;
|
|
end;
|
|
InternalStart;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseEngine.Stop;
|
|
begin
|
|
fBrowseStrategy := nil;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseEngine.TriggerBrowse(const Add: boolean; const AServiceName, aServiceType, aDomain: Unicodestring);
|
|
begin
|
|
fOwner.IntBrowseResult(GetCurrentEngineType, Add, AServiceName, aServiceType, aDomain);
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseEngine.TriggerError(anException: Exception);
|
|
begin
|
|
if Assigned(fBrowseStrategy) and
|
|
(fBrowseStrategy.GetCurrentEngineType = zceBonjour) and
|
|
(fOwner.Engine = zceAuto) and
|
|
Assigned(fOwner.GetHubClientClass(False)) then begin
|
|
fBrowseStrategy := CreateHubStrategy;
|
|
InternalStart;
|
|
end
|
|
else begin
|
|
try
|
|
InternalTriggerError(anException);
|
|
finally
|
|
Stop;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TROBonjourBrowseStrategy }
|
|
|
|
procedure TROBonjourBrowseStrategy.cbBrowse(service: TRONetService;
|
|
Add: boolean; AName, aType, aDomain: Unicodestring);
|
|
begin
|
|
fEngine.TriggerBrowse(Add, aName, aType, aDomain);
|
|
end;
|
|
|
|
procedure TROBonjourBrowseStrategy.cbError(Sender: TRODNSService;
|
|
anErrorCode: DNSServiceErrorType);
|
|
begin
|
|
if (anErrorCode <> kDNSServiceErr_NoError) then
|
|
if not fEngine.IsNeedToCreateException then
|
|
fEngine.TriggerError(nil)
|
|
else try
|
|
TROBrowseNetService.CreateDNSServiceBrowseException(anErrorCode);
|
|
except
|
|
on E: Exception do fEngine.TriggerError(E);
|
|
end;
|
|
end;
|
|
|
|
constructor TROBonjourBrowseStrategy.Create(aEngine: TROZeroConfBrowseEngine);
|
|
begin
|
|
inherited Create;
|
|
FEngine := aEngine;
|
|
end;
|
|
|
|
function TROBonjourBrowseStrategy.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
Result := zceBonjour;
|
|
end;
|
|
|
|
procedure TROBonjourBrowseStrategy.Start(const aDomain, aServiceType: UnicodeString);
|
|
begin
|
|
if Assigned(fBrowse) then Stop;
|
|
fBrowse := TROBrowseNetService.Create(aDomain, aServiceType);
|
|
fBrowse.OnError := cbError;
|
|
fBrowse.BrowseResult := cbBrowse;
|
|
fBrowse.Start();
|
|
end;
|
|
|
|
procedure TROBonjourBrowseStrategy.Stop;
|
|
begin
|
|
FreeAndNil(fBrowse);
|
|
end;
|
|
|
|
{ TROHubBrowseStrategy }
|
|
|
|
constructor TROHubBrowseStrategy.Create(const aEngine: TROZeroConfBrowseEngine; const aHubClientClass: TZeroConfHubClientClass);
|
|
begin
|
|
inherited Create;
|
|
fEngine := aEngine;
|
|
fHubClientClass := AHubClientClass;
|
|
end;
|
|
|
|
procedure ROBrowseResult(aHandle: String;aUserData: Pointer; aName, aType, aDomain: Unicodestring; aFlags: integer);
|
|
var
|
|
lAdd: Boolean;
|
|
begin
|
|
lAdd := (aFlags and hbDeleted) <> hbDeleted;
|
|
if Assigned(aUserData) then TROHubBrowseStrategy(aUserData).fEngine.TriggerBrowse(lAdd, aName, aType, aDomain);
|
|
end;
|
|
|
|
function TROHubBrowseStrategy.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
Result := zceROZeroConfHub;
|
|
end;
|
|
|
|
procedure TROHubBrowseStrategy.Start(const aDomain, aServiceType: UnicodeString);
|
|
var
|
|
lcallback: TROZeroConfResolveBrowseResult;
|
|
begin
|
|
lcallback := ROBrowseResult;
|
|
if fClient = nil then begin
|
|
fClient := fHubClientClass.Create;
|
|
try
|
|
fClient.Start;
|
|
except
|
|
FreeAndNil(fClient);
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
try
|
|
fClient.BrowseService(aServiceType, aDomain, Self, lcallback);
|
|
except
|
|
on e: Exception do fEngine.TriggerError(E);
|
|
end;
|
|
end;
|
|
|
|
procedure TROHubBrowseStrategy.Stop;
|
|
begin
|
|
FreeAndNil(fClient);
|
|
end;
|
|
|
|
{ TROZeroConfResolveEngine }
|
|
|
|
constructor TROZeroConfResolveEngine.Create(aConfService: TROZeroConfService);
|
|
begin
|
|
inherited Create;
|
|
fConfService := aConfService;
|
|
end;
|
|
|
|
function TROZeroConfResolveEngine.CreateHubStrategy: TROBaseZeroConfResolveStrategy;
|
|
var
|
|
lClientClass: TZeroConfHubClientClass;
|
|
begin
|
|
lClientClass := fConfService.FBrowser.GetHubClientClass(fConfService.DefEngine = zceROZeroConfHub);
|
|
if Assigned(lClientClass) then
|
|
Result := TROHubResolveStrategy.Create(Self, lClientClass)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
destructor TROZeroConfResolveEngine.Destroy;
|
|
begin
|
|
fResolveStrategy := nil;
|
|
inherited;
|
|
end;
|
|
|
|
function TROZeroConfResolveEngine.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
if fResolveStrategy = nil then
|
|
Result := fConfService.DefEngine
|
|
else
|
|
Result := fResolveStrategy.GetCurrentEngineType;
|
|
end;
|
|
|
|
function TROZeroConfResolveEngine.IntResolve(ADetectEngine: Boolean = False):Boolean;
|
|
var
|
|
lReRaise: Boolean;
|
|
lEngine: TROZeroConfEngine;
|
|
begin
|
|
if ADetectEngine then begin
|
|
lEngine := fConfService.DefEngine;
|
|
if lEngine = zceAuto then begin
|
|
if CheckDNSFunctions(False) then // Bonjour is present
|
|
lEngine := zceBonjour
|
|
else if fConfService.FBrowser.GetHubClientClass(False) <> nil then // Hub is present
|
|
lEngine := zceROZeroConfHub
|
|
else begin // bonjour and hub isn't present
|
|
Result := False;
|
|
if fRaiseException then CheckDNSFunctions(True);
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
case lEngine of
|
|
zceBonjour: fResolveStrategy := TROBonjourResolveStrategy.Create(self);
|
|
zceROZeroConfHub: fResolveStrategy := CreateHubStrategy;
|
|
zceNone: fResolveStrategy := nil;
|
|
end;
|
|
end;
|
|
|
|
Result := fResolveStrategy <> nil;
|
|
if not Result then begin
|
|
if fRaiseException then
|
|
raise EDNSServiceException.Create('Cannot detect valid engine for Resolve ',-1)
|
|
else
|
|
Exit;
|
|
end;
|
|
try
|
|
if fRaiseException then
|
|
fResolveStrategy.Resolve(fTimeOut)
|
|
else
|
|
Result := fResolveStrategy.TryResolve(fTimeOut);
|
|
except
|
|
Result := TriggerError(lReRaise);
|
|
if lReRaise then raise;
|
|
end;
|
|
end;
|
|
|
|
procedure TROZeroConfResolveEngine.Resolve(aTimeout: integer);
|
|
begin
|
|
fRaiseException := True;
|
|
fTimeOut := aTimeout;
|
|
IntResolve(True);
|
|
end;
|
|
|
|
function TROZeroConfResolveEngine.TriggerError(var aReRaise: Boolean): Boolean;
|
|
begin
|
|
if Assigned(fResolveStrategy) and
|
|
(fResolveStrategy.GetCurrentEngineType = zceBonjour) and
|
|
(fConfService.DefEngine = zceAuto) and
|
|
Assigned(fConfService.FBrowser.GetHubClientClass(False)) then begin
|
|
fResolveStrategy := CreateHubStrategy;
|
|
Result := IntResolve;
|
|
aReRaise:= False;
|
|
end
|
|
else begin
|
|
aReRaise := fRaiseException;
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function TROZeroConfResolveEngine.TryResolve(aTimeout: integer): Boolean;
|
|
begin
|
|
fRaiseException := False;
|
|
fTimeOut := aTimeout;
|
|
try
|
|
Result := IntResolve(True);
|
|
except
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
{ TROBonjourResolveStrategy }
|
|
|
|
constructor TROBonjourResolveStrategy.Create(aEngine: TROZeroConfResolveEngine);
|
|
begin
|
|
inherited Create;
|
|
FEngine := aEngine;
|
|
end;
|
|
|
|
function TROBonjourResolveStrategy.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
Result := zceBonjour;
|
|
end;
|
|
|
|
function TROBonjourResolveStrategy.IntResolve(
|
|
aTimeout: integer): DNSServiceErrorType;
|
|
var
|
|
lServ: TROResolveNetService;
|
|
lfullDomainName, lhostTarget: Unicodestring;
|
|
lport: integer;
|
|
ltxtRecord: AnsiString;
|
|
lIP4addresses, lIP6addresses: string;
|
|
begin
|
|
with fEngine.fConfService do
|
|
lServ := TROResolveNetService.Create(Domain,ServiceType,ServiceName);
|
|
try
|
|
Result := lServ.BlockResolve(aTimeout, fEngine.fConfService.fIpType, lfullDomainName, lhostTarget, lport, ltxtRecord, lIP4addresses, lIP6addresses);
|
|
if Result = kDNSServiceErr_NoError then
|
|
with fEngine.fConfService do begin
|
|
fFullDomainName:= lfullDomainName;
|
|
FHostTarget := lhostTarget;
|
|
FTextRecord := ltxtRecord;
|
|
fIP4Address := lIP4addresses;
|
|
fIP6Address := lIP6addresses;
|
|
fPort := lport;
|
|
fResolvedIP4 := fIP4Address <> '';
|
|
fResolvedIP6 := fIP6Address <> '';
|
|
FResolvedEngine := GetCurrentEngineType;
|
|
FResolved := fResolvedIP4 or fResolvedIP6;
|
|
end;
|
|
finally
|
|
lServ.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TROBonjourResolveStrategy.Resolve(aTimeout: integer);
|
|
var
|
|
lRaise: Boolean;
|
|
lResult: DNSServiceErrorType;
|
|
begin
|
|
lRaise := False;
|
|
lResult := 0;
|
|
try
|
|
lResult := IntResolve(aTimeout);
|
|
if lResult <> 0 then fEngine.TriggerError(lRaise);
|
|
except
|
|
// raise existing error
|
|
fEngine.TriggerError(lRaise);
|
|
if lRaise then raise;
|
|
end;
|
|
if lRaise then raise EDNSServiceException.Create('Resolve',lResult);
|
|
end;
|
|
|
|
function TROBonjourResolveStrategy.TryResolve(aTimeout: integer): Boolean;
|
|
var
|
|
lRaise: Boolean;
|
|
begin
|
|
try
|
|
Result := IntResolve(aTimeout) = 0;
|
|
except
|
|
// raise existing error
|
|
Result := fEngine.TriggerError(lRaise);
|
|
if lRaise then raise;
|
|
end;
|
|
end;
|
|
|
|
{ TROHubResolveStrategy }
|
|
|
|
constructor TROHubResolveStrategy.Create(aEngine: TROZeroConfResolveEngine;
|
|
const AHubClientClass: TZeroConfHubClientClass);
|
|
begin
|
|
inherited Create;
|
|
fEngine := aEngine;
|
|
fHubClientClass := AHubClientClass;
|
|
end;
|
|
|
|
destructor TROHubResolveStrategy.Destroy;
|
|
begin
|
|
FreeAndNil(fClient);
|
|
inherited;
|
|
end;
|
|
|
|
function TROHubResolveStrategy.GetCurrentEngineType: TROZeroConfEngine;
|
|
begin
|
|
Result := zceROZeroConfHub;
|
|
end;
|
|
|
|
function TROHubResolveStrategy.IntResolve(aTimeout: integer): Boolean;
|
|
var
|
|
lFullName,
|
|
lLocalAddress: Unicodestring;
|
|
lPort: integer;
|
|
lText: TROHubBytes;
|
|
lIP4, lIP6: string;
|
|
begin
|
|
if fClient = nil then begin
|
|
fClient := fHubClientClass.Create;
|
|
try
|
|
fClient.Start;
|
|
except
|
|
FreeAndNil(fClient);
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
try
|
|
with fEngine.fConfService do begin
|
|
Result := fClient.BlockResolve(aTimeout, ServiceName, ServiceType, Domain, fEngine.fConfService.fIpType, lFullName, lLocalAddress, lPort, lText, lIP4, lIP6);
|
|
if Result then begin
|
|
if EndsWith('.local', lLocalAddress) then SetLength(lLocalAddress, Length(lLocalAddress)-6);
|
|
fFullDomainName:= lFullName;
|
|
FHostTarget := lLocalAddress;
|
|
fPort := lPort;
|
|
FTextRecord := lText;
|
|
fIP4Address := lIP4;
|
|
fIP6Address := lIP6;
|
|
fResolvedIP4 := fIP4Address <> '';
|
|
fResolvedIP6 := fIP6Address <> '';
|
|
FResolvedEngine := GetCurrentEngineType;
|
|
FResolved := fResolvedIP4 or fResolvedIP6;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeAndNil(FClient);
|
|
end;
|
|
end;
|
|
|
|
procedure TROHubResolveStrategy.Resolve(aTimeout: integer);
|
|
var
|
|
lRaise: Boolean;
|
|
begin
|
|
try
|
|
IntResolve(aTimeout);
|
|
except
|
|
// raise existing error
|
|
fEngine.TriggerError(lRaise);
|
|
if lRaise then raise;
|
|
end;
|
|
end;
|
|
|
|
function TROHubResolveStrategy.TryResolve(aTimeout: integer): Boolean;
|
|
var
|
|
lRaise: Boolean;
|
|
begin
|
|
try
|
|
Result := IntResolve(aTimeout);
|
|
except
|
|
// raise existing error
|
|
Result := fEngine.TriggerError(lRaise);
|
|
if lRaise then raise;
|
|
end;
|
|
end;
|
|
|
|
{ TROZeroConfBrowseAndResolveEngine }
|
|
|
|
function TROZeroConfBrowseAndResolveEngine.BrowseAndResolve(aTimeout: integer; const aDomain, aServiceType, aHostTarget: UnicodeString;
|
|
out aFullDomainName: UnicodeString; out aPort: integer;out aTxtRecord: UnicodeString; out aAddresses: string; aIpType: TIpType = ipkAny): Boolean;
|
|
begin
|
|
fError := False;
|
|
FTimeout := aTimeout;
|
|
FHostTarget := aHostTarget;
|
|
FIpType := aIpType;
|
|
Start(aDomain, aServiceType);
|
|
Result := FEvent.WaitFor(aTimeout*1000) = wrSignaled;
|
|
if Result and not fError then begin
|
|
aFullDomainName := fFullDomainName;
|
|
aPort := fPort;
|
|
aTxtRecord := FTxtRecord;
|
|
aAddresses := FAddresses;
|
|
end
|
|
else begin
|
|
aFullDomainName := '';
|
|
aPort := 0;
|
|
aTxtRecord := '';
|
|
aAddresses := '';
|
|
end;
|
|
end;
|
|
|
|
constructor TROZeroConfBrowseAndResolveEngine.Create(
|
|
aOwner: TROZeroConfBrowser);
|
|
begin
|
|
inherited;
|
|
FEvent := TROEvent.Create(nil, False, False, '');
|
|
end;
|
|
|
|
destructor TROZeroConfBrowseAndResolveEngine.Destroy;
|
|
begin
|
|
FreeAndNil(FEvent);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseAndResolveEngine.InternalTriggerError(
|
|
anException: Exception);
|
|
begin
|
|
fError := True;
|
|
fEvent.SetEvent;
|
|
end;
|
|
|
|
procedure TROZeroConfBrowseAndResolveEngine.TriggerBrowse(
|
|
const Add: boolean; const AServiceName, aServiceType,
|
|
aDomain: Unicodestring);
|
|
|
|
function IncludeDot(aStr: UnicodeString): UnicodeString;
|
|
begin
|
|
Result := aStr;
|
|
if EndsWith(',',aStr) then Result:= aStr else Result:= aStr +'.';
|
|
end;
|
|
|
|
var
|
|
lRes : TROZeroConfService;
|
|
begin
|
|
if Add then begin
|
|
lRes := TROZeroConfService.Create(fOwner, GetCurrentEngineType, aDomain, AServiceName, aServiceType, fIpType);
|
|
try
|
|
if lRes.TryResolve(FTimeOut) then begin
|
|
if (ROWideCompare(lRes.HostTarget, fHostTarget,True) = 0) or // bonjour
|
|
(ROWideCompare(IncludeDot(lRes.HostTarget)+IncludeDot(aDomain), fHostTarget,True) = 0) // hub
|
|
then begin
|
|
fFullDomainName:= lRes.FullDomainName;
|
|
fPort:= lRes.Port;
|
|
fTxtRecord := lRes.TextRecord;
|
|
fAddresses := lRes.Address;
|
|
if assigned(fEvent) then fEvent.SetEvent;
|
|
end;
|
|
end;
|
|
finally
|
|
lRes.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
end.
|