aksdb
/
restemplate
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
restemplate/indy/Protocols/IdDNSServer.pas

4166 lines
140 KiB
Plaintext
Raw Permalink Blame History

{
$Project$
$Workfile$
$Revision$
$DateUTC$
$Id$
This file is part of the Indy (Internet Direct) project, and is offered
under the dual-licensing agreement described on the Indy website.
(http://www.indyproject.org/)
Copyright:
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
$Log$
Rev 1.40 3/4/2005 12:35:32 PM JPMugaas
Removed some compiler warnings.
Rev 1.39 2/9/2005 4:35:06 AM JPMugaas
Should compile.
Rev 1.38 2/8/05 6:13:02 PM RLebeau
Updated to use new AppendString() function in IdGlobal unit
Updated TIdDNS_ProcessThread.CompleteQuery() to use CopyTId...() functions
instead of ToBytes() and AppendBytes().
Rev 1.37 2005/1/25 ¤U¤È 12:25:26 DChang
Modify UpdateTree method, make the NS record can be save in the lower level
node.
Rev 1.36 2005/1/5 ¤U¤È 04:21:06 DChang Version: 1.36
Fix parsing procedure while processing TXT record, in pass version, double
quota will not be processed, but now, any charector between 2 double quotas
will be treated as TXT message.
Rev 1.35 2004/12/15 ¤U¤È 12:05:26 DChang Version: 1.35
1. Move UpdateTree to public section.
2. add DoUDPRead of TIdDNSServer.
3. Fix TIdDNS_ProcessThread.CompleteQuery and
InternalQuery to fit Indy 10 Core.
Rev 1.34 12/2/2004 4:23:50 PM JPMugaas
Adjusted for changes in Core.
Rev 1.33 2004.10.27 9:17:46 AM czhower
For TIdStrings
Rev 1.32 10/26/2004 9:06:32 PM JPMugaas
Updated references.
Rev 1.31 2004.10.26 1:06:26 PM czhower
Further fixes for aliaser
Rev 1.30 2004.10.26 12:01:32 PM czhower
Resolved alias conflict.
Rev 1.29 9/15/2004 4:59:52 PM DSiders
Added localization comments.
Rev 1.28 22/07/2004 18:14:22 ANeillans
Fixed compile error.
Rev 1.27 7/21/04 2:38:04 PM RLebeau
Removed redundant string copying in TIdDNS_ProcessThread constructor and
procedure QueryDomain() method
Removed local variable from TIdDNS_ProcessThread.SendData(), not needed
Rev 1.26 2004/7/21 ¤U¤È 06:37:48 DChang
Fix compile error in TIdDNS_ProcessThread.SendData, and mark a case statment
to comments in TIdDNS_ProcessThread.SaveToCache.
Rev 1.25 2004/7/19 ¤U¤È 09:55:52 DChang
1. Move all textmoderecords to IdDNSCommon.pas
2. Making DNS Server load the domain definition file while DNS Server
component is active.
3. Add a new event : OnAfterCacheSaved
4. Add Full name condition to indicate if a domain is empty
(ConvertDNtoString)
5. Make Query request processed with independent thread.
6. Rewrite TIdDNSServer into multiple thread mode, all queries will search
and assemble the answer, and then share the TIdSocketHandle to send answer
back.
7. Add version information in TIdDNSServer, so class CHAOS can be taken, but
only for the label : "version.bind.".
8. Fix TIdRR_TXT.BinQueryRecord, to make sure it can be parsed in DNS client.
9. Modify the AXFR function, reduce the response data size and quantity.
10. Move all TIdTextModeResourceRecord and derived classes to IdDNSCommon.pas
Rev 1.24 7/8/04 11:43:54 PM RLebeau
Updated TIdDNS_TCPServer.DoConnect() to use new BytesToString() parameters
Rev 1.23 7/7/04 1:45:16 PM RLebeau
Compiler fixes
Rev 1.22 6/29/04 1:43:30 PM RLebeau
Bug fixes for various property setters
Rev 1.21 2004.05.20 1:39:32 PM czhower
Last of the IdStream updates
Rev 1.20 2004.03.01 9:37:06 PM czhower
Fixed name conflicts for .net
Rev 1.19 2004.02.07 5:03:32 PM czhower
.net fixes.
Rev 1.18 2/7/2004 5:39:44 AM JPMugaas
IdDNSServer should compile in both DotNET and WIn32.
Rev 1.17 2004.02.03 5:45:58 PM czhower
Name changes
Rev 1.16 1/22/2004 8:26:40 AM JPMugaas
Ansi* calls changed.
Rev 1.15 1/21/2004 2:12:48 PM JPMugaas
InitComponent
Rev 1.14 12/7/2003 8:07:26 PM VVassiliev
string -> TIdBytes
Rev 1.13 2003.10.24 10:38:24 AM czhower
UDP Server todos
Rev 1.12 10/19/2003 12:16:30 PM DSiders
Added localization comments.
Rev 1.11 2003.10.12 3:50:40 PM czhower
Compile todos
Rev 1.10 2003/5/14 ¤W¤È 01:17:36 DChang
Fix a flag named denoted in the function which check if a domain correct.
Update the logic of UpdateTree functions (make them unified).
Update the TextRecord function of all TIdRR_ classes, it checks if the RRName
the same as FullName, if RRName = FullName, it will not append the Fullname
to RRName.
Rev 1.9 2003/5/10 ¤W¤È 01:09:42 DChang
Patch the domainlist update when axfr action.
Rev 1.8 2003/5/9 ¤W¤È 10:03:36 DChang
Modify the sequence of records. To make sure when we resolve MX record, the
mail host A record can be additional record section.
Rev 1.7 2003/5/8 ¤U¤È 08:11:34 DChang
Add TIdDNSMap, TIdDomainNameServerMapping to monitor primary DNS, and
detecting if the primary DNS record changed, it will update automatically if
necessary.
Rev 1.6 2003/5/2 ¤U¤È 03:39:38 DChang
Fix all compile warnings and hints.
Rev 1.5 4/29/2003 08:26:30 PM DenniesChang
Fix TIdDNSServer Create, the older version miss to create the FBindings.
fix AXFR procedure, fully support BIND 8 AXFR procedures.
Rev 1.4 4/28/2003 02:30:58 PM JPMugaas
reverted back to the old one as the new one checked will not compile, has
problametic dependancies on Contrs and Dialogs (both not permitted).
Rev 1.3 04/28/2003 01:15:10 AM DenniesChang
Rev 1.2 4/28/2003 07:00:18 AM JPMugaas
Should now compile.
Rev 1.0 11/14/2002 02:18:42 PM JPMugaas
// Ver: 2003-04-28-0115
// Combine TCP, UDP Tunnel into single TIdDNSServer component.
// Update TIdDNSServer from TIdUDPServer to TComponent.
// Ver: 2003-04-26-1810
// Add AXFR command.
// Ver: 2002-10-30-1253
// Add TIdRR_AAAA class, RFC 1884 (Ipv6 AAAA)
// and add the coresponding fix in TIdDNSServer, but left
// external search option for future.
// Ver: 2002-07-10-1610
// Add a new event : OnAfterSendBack to handle all
// data logged after query result is sent back to
// the client.
// Ver: 2002-05-27-0910
// Add a check function in SOA loading function.
// Ver: 2002-04-25-1530
// IdDNSServer. Ver: 2002-03-12-0900
// To-do: RFC 2136 Zone transfer must be implemented.
// Add FindHandedNodeByName to pass the TIdDNTreeNode Object back.
// Append a blank char when ClearQuota, to avoid the possible of
// losting a field.
// Add IdDNTree.SaveToFile
// Fix SOA RRName assignment.
// Fix PTRName RRName assignment.
// Fix TIdDNTreeNode RemoveChild
// IdDNSServer. Ver: 2002-02-26-1420
// Convert the DN Tree Node type, earlier verison just
// store the A, PTR in the upper domain node, current
// version save SOA and its subdomain in upper node.
//
// Moreover, move Cached_Tree, Handed_Tree to public
// section, for using convinent.
//
// I forget return CName data, fixed.
// Seperate the seaching of Cache and handled tree into 2
// parts with a flag.
//IdDNSServer. Ver: 2002-02-24-1715
// Move TIdDNSServer protected property RootDNS_NET to public
//IdDNSServer. Ver: 2002-02-23-1800
Original Programmer: Dennies Chang <dennies@ms4.hinet.net>
No Copyright. Code is given to the Indy Pit Crew.
This DNS Server supports only IN record, but not Chaos system.
Most of resource records in DNS server was stored with text mode,
event the TREE structure, it's just for convininet.
Why I did it with this way is tring to increase the speed for
implementation, with Delphi/Kylix internal class and object,
we can promise the compatible in Windows and Linux.
Started: Jan. 20, 2002.
First Finished: Feb. 23, 2002.
RFC 1035 WKS record is not implemented.
ToDO: Load Master File automaticlly when DNS Server Active.
ToDO: patch WKS record data type.
ToDO: prepare a Tree Editor for DNS Server Construction. (optional)
}
unit IdDNSServer;
interface
{$i IdCompilerDefines.inc}
uses
Classes,
IdContainers,
IdAssignedNumbers,
IdSocketHandle,
IdIOHandlerSocket,
IdGlobal,
IdGlobalProtocols,
IdBaseComponent,
IdComponent,
IdContext,
IdUDPBase,
IdResourceStrings,
IdExceptionCore,
IdDNSResolver,
IdUDPServer,
IdCustomTCPServer,
IdStackConsts,
IdThread,
IdDNSCommon;
type
TIdDomainExpireCheckThread = class(TIdThread)
protected
FInterval: UInt32;
FSender: TObject;
FTimerEvent: TNotifyEvent;
FBusy : Boolean;
FDomain : string;
FHost : string;
//
procedure Run; override;
procedure TimerEvent;
end;
// forward declaration.
TIdDNSMap = class;
TIdDNS_UDPServer = class;
// This class is to record the mapping of Domain and its primary DNS IP
TIdDomainNameServerMapping = class(TObject)
private
FHost: string;
FDomainName: string;
FBusy : Boolean;
FInterval: UInt32;
FList: TIdDNSMap;
procedure SetHost(const Value: string);
procedure SetInterval(const Value: UInt32);
protected
CheckScheduler : TIdDomainExpireCheckThread;
property Interval : UInt32 read FInterval write SetInterval;
property List : TIdDNSMap read FList write FList;
public
constructor Create(AList : TIdDNSMap);
destructor Destroy; override;
//You can not make methods and properties published in this class.
//If you want to make properties publishes, this has to derrive from TPersistant
//and be used by TPersistant in a published property.
// published
procedure SyncAndUpdate(Sender : TObject);
property Host : string read FHost write SetHost;
property DomainName : string read FDomainName write FDomainName;
end;
TIdDNSMap = class(TIdObjectList{$IFDEF HAS_GENERICS_TObjectList}<TIdDomainNameServerMapping>{$ENDIF})
private
FServer: TIdDNS_UDPServer;
{$IFNDEF HAS_GENERICS_TObjectList}
function GetItem(Index: Integer): TIdDomainNameServerMapping;
procedure SetItem(Index: Integer; const Value: TIdDomainNameServerMapping);
{$ENDIF}
procedure SetServer(const Value: TIdDNS_UDPServer);
public
constructor Create(Server: TIdDNS_UDPServer);
{$IFNDEF USE_OBJECT_ARC}
destructor Destroy; override;
{$ENDIF}
property Server : TIdDNS_UDPServer read FServer write SetServer;
{$IFNDEF HAS_GENERICS_TObjectList}
property Items[Index: Integer]: TIdDomainNameServerMapping read GetItem write SetItem; default;
{$ENDIF}
end;
TIdMWayTreeNodeClass = class of TIdMWayTreeNode;
// TODO: derive from TObjectList instead and remove SubTree member?
TIdMWayTreeNode = class(TObject)
private
SubTree : TIdObjectList{$IFDEF HAS_GENERICS_TObjectList}<TIdMWayTreeNode>{$ENDIF};
FFundmentalClass: TIdMWayTreeNodeClass;
function GetTreeNode(Index: Integer): TIdMWayTreeNode;
procedure SetFundmentalClass(const Value: TIdMWayTreeNodeClass);
procedure SetTreeNode(Index: Integer; const Value: TIdMWayTreeNode);
public
constructor Create(NodeClass : TIdMWayTreeNodeClass); virtual;
destructor Destroy; override;
property FundmentalClass : TIdMWayTreeNodeClass read FFundmentalClass write SetFundmentalClass;
property Children[Index : Integer] : TIdMWayTreeNode read GetTreeNode write SetTreeNode;
function AddChild : TIdMWayTreeNode;
function InsertChild(Index : Integer) : TIdMWayTreeNode;
procedure RemoveChild(Index : Integer);
end;
TIdDNTreeNode = class(TIdMWayTreeNode)
private
FCLabel : String;
FRRs: TIdTextModeRRs;
FChildIndex: TStrings;
FParentNode: TIdDNTreeNode;
FAutoSortChild: Boolean;
procedure SetCLabel(const Value: String);
procedure SetRRs(const Value: TIdTextModeRRs);
function GetNode(Index: integer): TIdDNTreeNode;
procedure SetNode(Index: integer; const Value: TIdDNTreeNode);
procedure SetChildIndex(const Value: TStrings);
function GetFullName: string;
function ConvertToDNString : string;
function DumpAllBinaryData(var RecordCount:integer) : TIdBytes;
public
property ParentNode : TIdDNTreeNode read FParentNode write FParentNode;
property CLabel : String read FCLabel write SetCLabel;
property RRs : TIdTextModeRRs read FRRs write SetRRs;
property Children[Index : Integer] : TIdDNTreeNode read GetNode write SetNode;
property ChildIndex : TStrings read FChildIndex write SetChildIndex;
property AutoSortChild : Boolean read FAutoSortChild write FAutoSortChild;
property FullName : string read GetFullName;
constructor Create(AParentNode : TIdDNTreeNode); reintroduce;
destructor Destroy; override;
function AddChild : TIdDNTreeNode;
function InsertChild(Index : Integer) : TIdDNTreeNode;
procedure RemoveChild(Index : Integer);
procedure SortChildren;
procedure Clear;
procedure SaveToFile(Filename : String);
function IndexByLabel(CLabel : String): Integer;
function IndexByNode(ANode : TIdDNTreeNode) : Integer;
end;
TIdDNS_TCPServer = class(TIdCustomTCPServer)
protected
FAccessList: TStrings;
FAccessControl: Boolean;
//
procedure DoConnect(AContext: TIdContext); override;
procedure InitComponent; override;
procedure SetAccessList(const Value: TStrings);
public
destructor Destroy; override;
published
property AccessList : TStrings read FAccessList write SetAccessList;
property AccessControl : boolean read FAccessControl write FAccessControl;
end;
TIdDNS_ProcessThread = class(TIdThread)
protected
FMyBinding: TIdSocketHandle;
FMainBinding: TIdSocketHandle;
FMyData: TStream;
FData : TIdBytes;
FServer: TIdDNS_UDPServer;
procedure SetMyBinding(const Value: TIdSocketHandle);
procedure SetMyData(const Value: TStream);
procedure SetServer(const Value: TIdDNS_UDPServer);
procedure ComposeErrorResult(var VFinal: TIdBytes; OriginalHeader: TDNSHeader;
OriginalQuestion : TIdBytes; ErrorStatus: Integer);
function CombineAnswer(Header : TDNSHeader; const EQuery, Answer : TIdBytes): TIdBytes;
procedure InternalSearch(Header: TDNSHeader; QName: string; QType: UInt16;
var Answer: TIdBytes; IfMainQuestion: Boolean; IsSearchCache: Boolean = False;
IsAdditional: Boolean = False; IsWildCard : Boolean = False;
WildCardOrgName: string = '');
procedure ExternalSearch(ADNSResolver: TIdDNSResolver; Header: TDNSHeader;
Question: TIdBytes; var Answer: TIdBytes);
function CompleteQuery(DNSHeader: TDNSHeader; Question: string;
OriginalQuestion: TIdBytes; var Answer : TIdBytes; QType, QClass : UInt16;
DNSResolver : TIdDNSResolver) : string;
procedure SaveToCache(ResourceRecord : TIdBytes; QueryName : string; OriginalQType : UInt16);
function SearchTree(Root : TIdDNTreeNode; QName : String; QType : UInt16): TIdDNTreeNode;
procedure Run; override;
procedure QueryDomain;
procedure SendData;
public
property MyBinding : TIdSocketHandle read FMyBinding write SetMyBinding;
property MyData: TStream read FMyData write SetMyData;
property Server : TIdDNS_UDPServer read FServer write SetServer;
constructor Create(ACreateSuspended: Boolean = True; Data : TIdBytes = nil;
MainBinding : TIdSocketHandle = nil; Binding : TIdSocketHandle = nil;
Server : TIdDNS_UDPServer = nil); reintroduce; overload;
destructor Destroy; override;
end;
TIdDNSBeforeQueryEvent = procedure(ABinding: TIdSocketHandle; ADNSHeader: TDNSHeader; var ADNSQuery: TIdBytes) of object;
TIdDNSAfterQueryEvent = procedure(ABinding: TIdSocketHandle; ADNSHeader: TDNSHeader; var QueryResult: TIdBytes; var ResultCode: string; Query : TIdBytes) of object;
TIdDNSAfterCacheSaved = procedure(CacheRoot : TIdDNTreeNode) of object;
TIdDNS_UDPServer = class(TIdUDPServer)
private
FBusy: Boolean;
protected
FAutoUpdateZoneInfo: Boolean;
FZoneMasterFiles: TStrings;
FRootDNS_NET: TStrings;
FCacheUnknowZone: Boolean;
FCached_Tree: TIdDNTreeNode;
FHanded_Tree: TIdDNTreeNode;
FHanded_DomainList: TStrings;
FAutoLoadMasterFile: Boolean;
FOnAfterQuery: TIdDNSAfterQueryEvent;
FOnBeforeQuery: TIdDNSBeforeQueryEvent;
FCS: TIdCriticalSection;
FOnAfterSendBack: TIdDNSAfterQueryEvent;
FOnAfterCacheSaved: TIdDNSAfterCacheSaved;
FGlobalCS: TIdCriticalSection;
FDNSVersion: string;
FofferDNSVersion: Boolean;
procedure DoBeforeQuery(ABinding: TIdSocketHandle; ADNSHeader: TDNSHeader;
var ADNSQuery : TIdBytes); dynamic;
procedure DoAfterQuery(ABinding: TIdSocketHandle; ADNSHeader: TDNSHeader;
var QueryResult : TIdBytes; var ResultCode : String; Query : TIdBytes); dynamic;
procedure DoAfterSendBack(ABinding: TIdSocketHandle; ADNSHeader: TDNSHeader;
var QueryResult : TIdBytes; var ResultCode : String; Query : TIdBytes); dynamic;
procedure DoAfterCacheSaved(CacheRoot : TIdDNTreeNode); dynamic;
procedure SetZoneMasterFiles(const Value: TStrings);
procedure SetRootDNS_NET(const Value: TStrings);
procedure SetHanded_DomainList(const Value: TStrings);
procedure InternalSearch(Header: TDNSHeader; QName: string; QType: UInt16;
var Answer: TIdBytes; IfMainQuestion: boolean; IsSearchCache: Boolean = False;
IsAdditional: Boolean = False; IsWildCard : Boolean = False;
WildCardOrgName: string = '');
procedure ExternalSearch(ADNSResolver: TIdDNSResolver; Header: TDNSHeader;
Question: TIdBytes; var Answer: TIdBytes);
//modified in May 2004 by Dennies Chang.
//procedure SaveToCache(ResourceRecord : string);
procedure SaveToCache(ResourceRecord : TIdBytes; QueryName : string; OriginalQType : UInt16);
//procedure UpdateTree(TreeRoot : TIdDNTreeNode; RR : TResultRecord); overload;
//MoveTo Public section for RaidenDNSD.
procedure InitComponent; override;
// Hide this property temporily, this property is prepared to maintain the
// TTL expired record auto updated;
property AutoUpdateZoneInfo : boolean read FAutoUpdateZoneInfo write FAutoUpdateZoneInfo;
property CS: TIdCriticalSection read FCS;
procedure DoUDPRead(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle); override;
public
destructor Destroy; override;
function AXFR(Header : TDNSHeader; Question : string; var Answer : TIdBytes) : string;
function CompleteQuery(DNSHeader: TDNSHeader; Question: string;
OriginalQuestion: TIdBytes; var Answer : TIdBytes; QType, QClass : UInt16;
DNSResolver : TIdDNSResolver) : string; {$IFDEF HAS_DEPRECATED}deprecated;{$ENDIF}
function LoadZoneFromMasterFile(MasterFileName : String) : boolean;
function LoadZoneStrings(FileStrings: TStrings; Filename : String;
TreeRoot : TIdDNTreeNode): Boolean;
function SearchTree(Root : TIdDNTreeNode; QName : String; QType : UInt16): TIdDNTreeNode;
procedure UpdateTree(TreeRoot : TIdDNTreeNode; RR : TIdTextModeResourceRecord); overload;
function FindNodeFullName(Root : TIdDNTreeNode; QName : String; QType : UInt16) : string;
function FindHandedNodeByName(QName : String; QType : UInt16) : TIdDNTreeNode;
procedure UpdateTree(TreeRoot : TIdDNTreeNode; RR : TResultRecord); overload;
property RootDNS_NET : TStrings read FRootDNS_NET write SetRootDNS_NET;
property Cached_Tree : TIdDNTreeNode read FCached_Tree {write SetCached_Tree};
property Handed_Tree : TIdDNTreeNode read FHanded_Tree {write SetHanded_Tree};
property Busy : Boolean read FBusy;
property GlobalCS : TIdCriticalSection read FGlobalCS;
published
property DefaultPort default IdPORT_DOMAIN;
property AutoLoadMasterFile : Boolean read FAutoLoadMasterFile write FAutoLoadMasterFile Default False;
//property AutoUpdateZoneInfo : boolean read FAutoUpdateZoneInfo write SetAutoUpdateZoneInfo;
property ZoneMasterFiles : TStrings read FZoneMasterFiles write SetZoneMasterFiles;
property CacheUnknowZone : Boolean read FCacheUnknowZone write FCacheUnknowZone default False;
property Handed_DomainList : TStrings read FHanded_DomainList write SetHanded_DomainList;
property DNSVersion : string read FDNSVersion write FDNSVersion;
property offerDNSVersion : Boolean read FofferDNSVersion write FofferDNSVersion;
property OnBeforeQuery : TIdDNSBeforeQueryEvent read FOnBeforeQuery write FOnBeforeQuery;
property OnAfterQuery : TIdDNSAfterQueryEvent read FOnAfterQuery write FOnAfterQuery;
property OnAfterSendBack : TIdDNSAfterQueryEvent read FOnAfterSendBack write FOnAfterSendBack;
property OnAfterCacheSaved : TIdDNSAfterCacheSaved read FOnAfterCacheSaved write FOnAfterCacheSaved;
end;
TIdDNSServer = class(TIdComponent)
protected
FActive: Boolean;
FTCPACLActive: Boolean;
FServerType: TDNSServerTypes;
FTCPTunnel: TIdDNS_TCPServer;
FUDPTunnel: TIdDNS_UDPServer;
FAccessList: TStrings;
FBindings: TIdSocketHandles;
procedure SetAccessList(const Value: TStrings);
procedure SetActive(const Value: Boolean);
procedure SetTCPACLActive(const Value: Boolean);
procedure SetBindings(const Value: TIdSocketHandles);
procedure TimeToUpdateNodeData(Sender : TObject);
procedure InitComponent; override;
public
BackupDNSMap : TIdDNSMap;
destructor Destroy; override;
procedure CheckIfExpire(Sender: TObject);
published
property Active : Boolean read FActive write SetActive;
property AccessList : TStrings read FAccessList write SetAccessList;
property Bindings: TIdSocketHandles read FBindings write SetBindings;
property TCPACLActive : Boolean read FTCPACLActive write SetTCPACLActive;
property ServerType: TDNSServerTypes read FServerType write FServerType;
property TCPTunnel : TIdDNS_TCPServer read FTCPTunnel write FTCPTunnel;
property UDPTunnel : TIdDNS_UDPServer read FUDPTunnel write FUDPTunnel;
end;
implementation
uses
{$IFDEF VCL_XE3_OR_ABOVE}
{$IFNDEF NEXTGEN}
System.Contnrs,
{$ENDIF}
System.SyncObjs,
System.Types,
{$ENDIF}
IdException,
{$IFDEF DOTNET}
{$IFDEF USE_INLINE}
System.Threading,
System.IO,
{$ENDIF}
{$ENDIF}
{$IFDEF USE_VCL_POSIX}
Posix.SysSelect,
Posix.SysTime,
{$ENDIF}
IdIOHandler,
IdStack,
SysUtils;
{Common Utilities}
function CompareItems(Item1, Item2: {$IFDEF HAS_GENERICS_TObjectList}TIdMWayTreeNode{$ELSE}TObject{$ENDIF}): Integer;
var
LObj1, LObj2 : TIdDNTreeNode;
begin
LObj1 := Item1 as TIdDNTreeNode;
LObj2 := Item2 as TIdDNTreeNode;
Result := CompareStr(LObj1.CLabel, LObj2.CLabel);
end;
// TODO: move to IdGlobal.pas
function PosBytes(const SubBytes, SBytes: TIdBytes): Integer;
var
LSubLen, LBytesLen, I: Integer;
begin
LSubLen := Length(SubBytes);
LBytesLen := Length(SBytes);
if (LSubLen > 0) and (LBytesLen >= LSubLen) then
begin
for Result := 0 to LBytesLen-LSubLen do
begin
if SBytes[Result] = SubBytes[0] then
begin
for I := 1 to LSubLen-1 do
begin
if SBytes[Result+I] <> SubBytes[I] then begin
Break;
end;
end;
if I = LSubLen then begin
Exit;
end;
end;
end;
end;
Result := -1;
end;
// TODO: move to IdGlobal.pas
function FetchBytes(var AInput: TIdBytes; const ADelim: TIdBytes;
const ADelete: Boolean = IdFetchDeleteDefault): TIdBytes;
var
LPos: integer;
begin
LPos := PosBytes(ADelim, AInput);
if LPos = -1 then begin
Result := AInput;
if ADelete then begin
SetLength(AInput, 0);
end;
end
else begin
Result := ToBytes(AInput, LPos);
if ADelete then begin
//slower Delete(AInput, 1, LPos + Length(ADelim) - 1);
RemoveBytes(AInput, LPos + Length(ADelim));
end;
end;
end;
{ TIdMWayTreeNode }
function TIdMWayTreeNode.AddChild: TIdMWayTreeNode;
begin
Result := FundmentalClass.Create(FundmentalClass);
try
SubTree.Add(Result);
except
FreeAndNil(Result);
raise;
end;
end;
constructor TIdMWayTreeNode.Create(NodeClass : TIdMWayTreeNodeClass);
begin
inherited Create;
FundmentalClass := NodeClass;
SubTree := TIdObjectList{$IFDEF HAS_GENERICS_TObjectList}<TIdMWayTreeNode>{$ENDIF}.Create;
end;
destructor TIdMWayTreeNode.Destroy;
begin
FreeAndNil(SubTree);
inherited Destroy;
end;
function TIdMWayTreeNode.GetTreeNode(Index: Integer): TIdMWayTreeNode;
begin
Result := {$IFDEF HAS_GENERICS_TObjectList}SubTree.Items[Index]{$ELSE}TIdMWayTreeNode(SubTree.Items[Index]){$ENDIF};
end;
function TIdMWayTreeNode.InsertChild(Index: Integer): TIdMWayTreeNode;
begin
Result := FundmentalClass.Create(FundmentalClass);
try
SubTree.Insert(Index, Result);
except
FreeAndNil(Result);
raise;
end;
end;
procedure TIdMWayTreeNode.RemoveChild(Index: Integer);
begin
SubTree.Delete(Index);
end;
procedure TIdMWayTreeNode.SetFundmentalClass(const Value: TIdMWayTreeNodeClass);
begin
FFundmentalClass := Value;
end;
procedure TIdMWayTreeNode.SetTreeNode(Index: Integer; const Value: TIdMWayTreeNode);
begin
{$IFNDEF USE_OBJECT_ARC}
SubTree.Items[Index].Free;
{$ENDIF}
SubTree.Items[Index] := Value;
end;
{ TIdDNTreeNode }
function TIdDNTreeNode.AddChild: TIdDNTreeNode;
begin
Result := TIdDNTreeNode.Create(Self);
try
SubTree.Add(Result);
except
FreeAndNil(Result);
raise;
end;
end;
procedure TIdDNTreeNode.Clear;
var
I : Integer;
begin
for I := SubTree.Count - 1 downto 0 do begin
RemoveChild(I);
end;
end;
function TIdDNTreeNode.ConvertToDNString: string;
var
Count : Integer;
begin
Result := '$ORIGIN ' + FullName + EOL; {do not localize}
for Count := 0 to RRs.Count-1 do begin
Result := Result + RRs.Items[Count].TextRecord(FullName);
end;
for Count := 0 to FChildIndex.Count-1 do begin
Result := Result + Children[Count].ConvertToDNString;
end;
end;
constructor TIdDNTreeNode.Create(AParentNode : TIdDNTreeNode);
begin
inherited Create(TIdDNTreeNode);
FRRs := TIdTextModeRRs.Create;
FChildIndex := TStringList.Create;
FParentNode := AParentNode;
end;
destructor TIdDNTreeNode.Destroy;
begin
FreeAndNil(FRRs);
FreeAndNil(FChildIndex);
inherited Destroy;
end;
function TIdDNTreeNode.DumpAllBinaryData(var RecordCount: Integer): TIdBytes;
var
Count, ChildCount : integer;
MyString, ChildString : TIdBytes;
begin
SetLength(ChildString, 0);
SetLength(MyString, 0);
Inc(RecordCount, RRs.Count + 1);
for Count := 0 to RRs.Count -1 do
begin
AppendBytes(MyString, RRs.Items[Count].BinQueryRecord(FullName));
end;
for Count := 0 to FChildIndex.Count -1 do
begin
// RLebeau: should ChildCount be set to 0 each time?
AppendBytes(ChildString, Children[Count].DumpAllBinaryData(ChildCount));
Inc(RecordCount, ChildCount);
end;
if RRs.Count > 0 then begin
if RRs.Items[0] is TIdRR_SOA then begin
AppendBytes(MyString, RRs.Items[0].BinQueryRecord(FullName));
Inc(RecordCount);
end;
end;
Result := MyString;
AppendBytes(Result, ChildString);
if RRs.Count > 0 then begin
AppendBytes(Result, RRs.Items[0].BinQueryRecord(FullName));
end;
end;
function TIdDNTreeNode.GetFullName: string;
begin
if ParentNode = nil then begin
if CLabel = '.' then begin
Result := '';
end else begin
Result := CLabel;
end;
end else begin
Result := CLabel + '.' + ParentNode.FullName;
end;
end;
function TIdDNTreeNode.GetNode(Index: Integer): TIdDNTreeNode;
begin
Result := TIdDNTreeNode(SubTree.Items[Index]);
end;
function TIdDNTreeNode.IndexByLabel(CLabel: String): Integer;
begin
Result := FChildIndex.IndexOf(CLabel);
end;
function TIdDNTreeNode.IndexByNode(ANode: TIdDNTreeNode): Integer;
begin
Result := SubTree.IndexOf(ANode);
end;
function TIdDNTreeNode.InsertChild(Index: Integer): TIdDNTreeNode;
begin
Result := TIdDNTreeNode.Create(Self);
try
SubTree.Insert(Index, Result);
except
FreeAndNil(Result);
raise;
end;
end;
procedure TIdDNTreeNode.RemoveChild(Index: Integer);
begin
SubTree.Remove(SubTree.Items[Index]);
FChildIndex.Delete(Index);
end;
procedure TIdDNTreeNode.SaveToFile(Filename: String);
var
DNSs : TStrings;
begin
DNSs := TStringList.Create;
try
DNSs.Add(ConvertToDNString);
ToDo('SaveToFile() method of TIdDNTreeNode class is not implemented yet'); {do not localized}
// DNSs.SaveToFile(Filename);
finally
FreeAndNil(DNSs);
end;
end;
procedure TIdDNTreeNode.SetChildIndex(const Value: TStrings);
begin
FChildIndex.Assign(Value);
end;
procedure TIdDNTreeNode.SetCLabel(const Value: String);
begin
FCLabel := Value;
if ParentNode <> nil then begin
ParentNode.ChildIndex.Insert(ParentNode.SubTree.IndexOf(Self), Value);
end;
if AutoSortChild then begin
SortChildren;
end;
end;
procedure TIdDNTreeNode.SetNode(Index: Integer; const Value: TIdDNTreeNode);
begin
SubTree.Items[Index] := Value;
end;
procedure TIdDNTreeNode.SetRRs(const Value: TIdTextModeRRs);
begin
FRRs.Assign(Value);
end;
procedure TIdDNTreeNode.SortChildren;
begin
SubTree.BubbleSort(CompareItems);
TStringList(FChildIndex).Sort;
end;
{ TIdDNSServer }
{$I IdDeprecatedImplBugOff.inc}
function TIdDNS_UDPServer.CompleteQuery(DNSHeader : TDNSHeader; Question: string;
OriginalQuestion: TIdBytes; var Answer: TIdBytes; QType, QClass: UInt16;
DNSResolver : TIdDNSResolver): string;
{$I IdDeprecatedImplBugOn.inc}
var
IsMyDomains : Boolean;
LAnswer: TIdBytes;
WildQuestion, TempDomain : string;
begin
// QClass = 1 => IN, we support only "IN" class now.
// QClass = 2 => CS,
// QClass = 3 => CH,
// QClass = 4 => HS.
if QClass <> 1 then begin
Result := cRCodeQueryNotImplement;
Exit;
end;
TempDomain := LowerCase(Question);
IsMyDomains := (Handed_DomainList.IndexOf(TempDomain) > -1);
if not IsMyDomains then begin
Fetch(TempDomain, '.');
IsMyDomains := (Handed_DomainList.IndexOf(TempDomain) > -1);
end;
if IsMyDomains then begin
InternalSearch(DNSHeader, Question, QType, LAnswer, True, False, False);
Answer := LAnswer;
if (QType in [TypeCode_A, TypeCode_AAAA]) and (Length(Answer) = 0) then
begin
InternalSearch(DNSHeader, Question, TypeCode_CNAME, LAnswer, True, False, True);
AppendBytes(Answer, LAnswer);
end;
WildQuestion := Question;
Fetch(WildQuestion, '.');
WildQuestion := '*.' + WildQuestion;
InternalSearch(DNSHeader, WildQuestion, QType, LAnswer, True, False, False, True, Question);
AppendBytes(Answer, LAnswer);
if Length(Answer) > 0 then begin
Result := cRCodeQueryOK;
end else begin
Result := cRCodeQueryNotFound;
end;
end else
begin
InternalSearch(DNSHeader, Question, QType, Answer, True, True, False);
if (QType in [TypeCode_A, TypeCode_AAAA]) and (Length(Answer) = 0) then
begin
InternalSearch(DNSHeader, Question, TypeCode_CNAME, LAnswer, True, True, False);
AppendBytes(Answer, LAnswer);
end;
if Length(Answer) > 0 then begin
Result := cRCodeQueryCacheOK;
Exit;
end;
InternalSearch(DNSHeader, Question, TypeCode_Error, Answer, True, True, False);
if BytesToString(Answer) = 'Error' then begin {do not localize}
Result := cRCodeQueryCacheFindError;
Exit;
end;
ExternalSearch(DNSResolver, DNSHeader, OriginalQuestion, Answer);
if Length(Answer) > 0 then begin
Result := cRCodeQueryReturned;
end else begin
Result := cRCodeQueryNotImplement;
end;
end
end;
procedure TIdDNS_UDPServer.InitComponent;
begin
inherited InitComponent;
FRootDNS_NET := TStringList.Create;
FRootDNS_NET.Add('209.92.33.150'); // nic.net {do not localize}
FRootDNS_NET.Add('209.92.33.130'); // nic.net {do not localize}
FRootDNS_NET.Add('203.37.255.97'); // apnic.net {do not localize}
FRootDNS_NET.Add('202.12.29.131'); // apnic.net {do not localize}
FRootDNS_NET.Add('12.29.20.2'); // nanic.net {do not localize}
FRootDNS_NET.Add('204.145.119.2'); // nanic.net {do not localize}
FRootDNS_NET.Add('140.111.1.2'); // a.twnic.net.tw {do not localize}
FCached_Tree := TIdDNTreeNode.Create(nil);
FCached_Tree.AutoSortChild := True;
FCached_Tree.CLabel := '.';
FHanded_Tree := TIdDNTreeNode.Create(nil);
FHanded_Tree.AutoSortChild := True;
FHanded_Tree.CLabel := '.';
FHanded_DomainList := TStringList.Create;
FZoneMasterFiles := TStringList.Create;
DefaultPort := IdPORT_DOMAIN;
FCS := TIdCriticalSection.Create;
FGlobalCS := TIdCriticalSection.Create;
FBusy := False;
end;
destructor TIdDNS_UDPServer.Destroy;
begin
FreeAndNil(FCached_Tree);
FreeAndNil(FHanded_Tree);
FreeAndNil(FRootDNS_NET);
FreeAndNil(FHanded_DomainList);
FreeAndNil(FZoneMasterFiles);
FreeAndNil(FCS);
FreeAndNil(FGlobalCS);
inherited Destroy;
end;
procedure TIdDNS_UDPServer.DoAfterQuery(ABinding: TIdSocketHandle;
ADNSHeader: TDNSHeader; var QueryResult: TIdBytes; var ResultCode : String;
Query : TIdBytes);
begin
if Assigned(FOnAfterQuery) then begin
FOnAfterQuery(ABinding, ADNSHeader, QueryResult, ResultCode, Query);
end;
end;
procedure TIdDNS_UDPServer.DoBeforeQuery(ABinding: TIdSocketHandle;
ADNSHeader: TDNSHeader; var ADNSQuery: TIdBytes);
begin
if Assigned(FOnBeforeQuery) then begin
FOnBeforeQuery(ABinding, ADNSHeader, ADNSQuery);
end;
end;
procedure TIdDNS_UDPServer.ExternalSearch(ADNSResolver : TIdDNSResolver;
Header: TDNSHeader; Question: TIdBytes; var Answer: TIdBytes);
var
Server_Index : Integer;
MyDNSResolver : TIdDNSResolver;
begin
if RootDNS_NET.Count = 0 then begin
Exit;
end;
Server_Index := 0;
if ADNSResolver = nil then begin
MyDNSResolver := TIdDNSResolver.Create(Self);
MyDNSResolver.WaitingTime := 5000;
end else begin
MyDNSResolver := ADNSResolver;
end;
try
repeat
MyDNSResolver.Host := RootDNS_NET.Strings[Server_Index];
try
MyDNSResolver.InternalQuery := Question;
MyDNSResolver.Resolve('');
Answer := MyDNSResolver.PlainTextResult;
except
// Todo: Create DNS server interal resolver error.
on EIdDnsResolverError do begin
//Empty Event, for user to custom the event handle.
end;
on EIdSocketError do begin
end;
else
begin
end;
end;
Inc(Server_Index);
until (Server_Index >= RootDNS_NET.Count) or (Length(Answer) > 0);
finally
if ADNSResolver = nil then begin
FreeAndNil(MyDNSResolver);
end;
end;
end;
function TIdDNS_UDPServer.FindHandedNodeByName(QName: String; QType: UInt16): TIdDNTreeNode;
begin
Result := SearchTree(Handed_Tree, QName, QType);
end;
function TIdDNS_UDPServer.FindNodeFullName(Root: TIdDNTreeNode; QName: String; QType : UInt16): string;
var
MyNode : TIdDNTreeNode;
begin
MyNode := SearchTree(Root, QName, QType);
if MyNode <> nil then begin
Result := MyNode.FullName;
end else begin
Result := '';
end;
end;
function TIdDNS_UDPServer.LoadZoneFromMasterFile(MasterFileName: String): Boolean;
var
FileStrings : TStrings;
begin
{MakeTagList;}
Result := FileExists(MasterFileName);
if Result then begin
FileStrings := TStringList.Create;
try
Todo('LoadZoneFromMasterFile() method of TIdDNS_UDPServer class is not implemented yet'); {do not localize}
// FileStrings.LoadFromFile(MasterFileName);
Result := LoadZoneStrings(FileStrings, MasterFileName, Handed_Tree);
finally
FreeAndNil(FileStrings);
end;
end;
{FreeTagList;}
end;
function TIdDNS_UDPServer.LoadZoneStrings(FileStrings: TStrings; Filename : String;
TreeRoot : TIdDNTreeNode): Boolean;
var
TagList : TStrings;
function IsMSDNSFileName(theFileName : String; var DN: string) : Boolean;
var
namepart : TStrings;
Fullname : string;
Count : Integer;
begin
Fullname := theFilename;
repeat
if Pos('\', Fullname) > 0 then begin
Fetch(Fullname, '\');
end;
until Pos('\', Fullname) = 0;
namepart := TStringList.Create;
try
repeat
namepart.Add(Fetch(Fullname, '.'));
until Fullname = '';
Result := namepart.Strings[namepart.Count-1] = 'dns'; {do not localize}
if Result then begin
Count := 0;
DN := namepart.Strings[Count];
repeat
Inc(Count);
if Count <= namepart.Count -2 then begin
DN := DN + '.' + namepart.Strings[Count];
end;
until Count >= (namepart.Count-2);
end;
finally
FreeAndNil(namepart);
end;
end;
procedure MakeTagList;
begin
TagList := TStringList.Create;
try
TagList.Add(cAAAA);
TagList.Add(cA);
TagList.Add(cNS);
TagList.Add(cMD);
TagList.Add(cMF);
TagList.Add(cCName);
TagList.Add(cSOA);
TagList.Add(cMB);
TagList.Add(cMG);
TagList.Add(cMR);
TagList.Add(cNULL);
TagList.Add(cWKS);
TagList.Add(cPTR);
TagList.Add(cHINFO);
TagList.Add(cMINFO);
TagList.Add(cMX);
TagList.Add(cTXT);
// The Following Tags are used in master file, but not Resource Record.
TagList.Add(cOrigin);
TagList.Add(cInclude);
//TagList.Add(cAt);
except
FreeAndNil(TagList);
raise;
end;
end;
procedure FreeTagList;
begin
FreeAndNil(TagList);
end;
function ClearDoubleQutoa(Strs : TStrings): Boolean;
var
SSCount : Integer;
Mark, Found : Boolean;
begin
SSCount := 0;
Mark := False;
while SSCount <= (Strs.Count-1) do begin
Found := Pos('"', Strs.Strings[SSCount]) > 0;
while Found do begin
Mark := Mark xor Found;
Strs.Strings[SSCount] := ReplaceSpecString(Strs.Strings[SSCount], '"', '', False);
Found := Pos('"', Strs.Strings[SSCount]) > 0;
end;
if not Mark then begin
Inc(SSCount);
end else begin
Strs.Strings[SSCount] := Strs.Strings[SSCount] + ' ' + Strs.Strings[SSCount + 1];
Strs.Delete(SSCount + 1);
end;
end;
Result := not Mark;
end;
function IsValidMasterFile : Boolean;
var
EachLinePart : TStrings;
CurrentLineNum, TagField, Count : Integer;
LineData, DataBody, {Comment,} FPart, LTag : string;
Denoted, Stop, PassQuota : Boolean;
begin
EachLinePart := TStringList.Create;
try
CurrentLineNum := 0;
Stop := False;
// Check Denoted;
Denoted := false;
if FileStrings.Count > 0 then begin
repeat
LineData := Trim(FileStrings.Strings[CurrentLineNum]);
DataBody := Fetch(LineData, ';');
//Comment := LineData;
PassQuota := Pos('(', DataBody) = 0;
// Split each item into TStrings.
repeat
if not PassQuota then begin
Inc(CurrentLineNum);
LineData := Trim(FileStrings.Strings[CurrentLineNum]);
DataBody := DataBody + ' ' + Fetch(LineData, ';');
PassQuota := Pos(')', DataBody) > 0;
end;
until PassQuota or (CurrentLineNum > (FileStrings.Count-1));
Stop := not PassQuota;
if not Stop then begin
EachLinePart.Clear;
DataBody := ReplaceSpecString(DataBody, '(', '');
DataBody := ReplaceSpecString(DataBody, ')', '');
repeat
DataBody := Trim(DataBody);
FPart := Fetch(DataBody, #9);
repeat
FPart := Trim(FPart);
LTag := Fetch(FPart,' ');
if (LTag <> '') and (LTag <> '(') and (LTag <> ')') then begin
EachLinePart.Add(LTag);
end;
until FPart = '';
until DataBody = '';
if not Denoted then begin
if EachLinePart.Count > 1 then begin
Denoted := (EachLinePart.Strings[0] = cOrigin) or (EachLinePart.IndexOf(cSOA) <> -1);
end else begin
Denoted := False;
end;
end;
// Check Syntax;
if not ((EachLinePart.Count > 0) and (EachLinePart.Strings[0] = cOrigin)) then
begin
if not Denoted then begin
if EachLinePart.Count > 0 then begin
Stop := (EachLinePart.Count > 0) and (EachLinePart.IndexOf(cSOA) = -1);
end else begin
Stop := False;
end;
end else begin
//TagField := -1;
//FieldCount := 0;
// Search Tag Named 'IN';
TagField := EachLinePart.IndexOf('IN'); {do not localize}
if TagField = -1 then begin
Count := 0;
repeat
if EachLinePart.Count > 0 then begin
TagField := TagList.IndexOf(EachLinePart.Strings[Count]);
end;
Inc(Count);
until (Count >= EachLinePart.Count -1) or (TagField <> -1);
if TagField <> -1 then begin
TagField := Count;
end;
end else begin
if TagList.IndexOf(EachLinePart.Strings[TagField + 1]) = -1 then begin
TagField := -1;
end else begin
Inc(TagField);
end;
end;
if TagField > -1 then begin
case TagList.IndexOf(EachLinePart.Strings[TagField]) of
// Check ip
TypeCode_A : Stop := not IsValidIP(EachLinePart.Strings[TagField + 1]);
// Check ip v6
0 : Stop := not IsValidIPv6(EachLinePart.Strings[TagField + 1]);
// Check Domain Name
TypeCode_CName, TypeCode_NS, TypeCode_MR,
TypeCode_MD, TypeCode_MB, TypeCode_MG,
TypeCode_MF: Stop := not IsHostName(EachLinePart.Strings[TagField + 1]);
// Can be anything
TypeCode_TXT, TypeCode_NULL: Stop := False;
// Must be FQDN.
TypeCode_PTR: Stop := not IsFQDN(EachLinePart.Strings[TagField + 1]);
// HINFO should has 2 fields : CPU and OS. but TStrings
// is 0 base, so that we have to minus one
TypeCode_HINFO:
begin
Stop := not (ClearDoubleQutoa(EachLinePart) and
((EachLinePart.Count - TagField - 1) = 2));
end;
// Check RMailBX and EMailBX but TStrings
// is 0 base, so that we have to minus one
TypeCode_MINFO:
begin
Stop := ((EachLinePart.Count - TagField - 1) <> 2);
if not Stop then begin
Stop := not (IsHostName(EachLinePart.Strings[TagField + 1]) and
IsHostName(EachLinePart.Strings[TagField + 2]));
end;
end;
// Check Pref(Numeric) and Exchange. but TStrings
// is 0 base, so that we have to minus one
TypeCode_MX:
begin
Stop := ((EachLinePart.Count - TagField - 1) <> 2);
if not Stop then begin
Stop := not (IsNumeric(EachLinePart.Strings[TagField + 1]) and
IsHostName(EachLinePart.Strings[TagField + 2]));
end;
end;
// TStrings is 0 base, so that we have to minus one
TypeCode_SOA:
begin
Stop := ((EachLinePart.Count - TagField - 1) <> 7);
if not Stop then begin
Stop := not (IsHostName(EachLinePart.Strings[TagField + 1]) and
IsHostName(EachLinePart.Strings[TagField + 2]) and
IsNumeric(EachLinePart.Strings[TagField + 3]) and
IsNumeric(EachLinePart.Strings[TagField + 4]) and
IsNumeric(EachLinePart.Strings[TagField + 5]) and
IsNumeric(EachLinePart.Strings[TagField + 6]) and
IsNumeric(EachLinePart.Strings[TagField + 7])
);
end;
end;
TypeCode_WKS: Stop := ((EachLinePart.Count - TagField) = 1);
end;
end else begin
if EachLinePart.Count > 0 then
Stop := True;
end;
end;
end;
end;
Inc(CurrentLineNum);
until (CurrentLineNum > (FileStrings.Count-1)) or Stop;
end;
Result := not Stop;
finally
FreeAndNil(EachLinePart);
end;
end;
function LoadMasterFile : Boolean;
var
Checks, EachLinePart, DenotedDomain : TStrings;
CurrentLineNum, TagField, Count, LastTTL : Integer;
LineData, DataBody, FPart, LTag, LText,
RName, LastDenotedDomain, LastTag, NewDomain, SingleHostName {CH: , PrevDNTag} : string;
Stop, PassQuota, Found {, canChangPrevDNTag } : Boolean;
LLRR_A : TIdRR_A;
LLRR_AAAA : TIdRR_AAAA;
LLRR_NS : TIdRR_NS;
LLRR_MB : TIdRR_MB;
LLRR_Name : TIdRR_CName;
LLRR_SOA : TIdRR_SOA;
LLRR_MG : TIdRR_MG;
LLRR_MR : TIdRR_MR;
LLRR_PTR : TIdRR_PTR;
LLRR_HINFO : TIdRR_HINFO;
LLRR_MINFO : TIdRR_MINFO;
LLRR_MX : TIdRR_MX;
LLRR_TXT : TIdRR_TXT;
begin
EachLinePart := TStringList.Create;
try
DenotedDomain := TStringList.Create;
try
CurrentLineNum := 0;
LastDenotedDomain := '';
LastTag := '';
NewDomain := '';
// PrevDNTag := '';
Stop := False;
//canChangPrevDNTag := True;
if IsMSDNSFileName(FileName, LastDenotedDomain) then begin
//canChangPrevDNTag := False;
Filename := Uppercase(Filename);
end else begin
LastDenotedDomain := '';
end;
if FileStrings.Count > 0 then begin
repeat
LineData := Trim(FileStrings.Strings[CurrentLineNum]);
DataBody := Fetch(LineData, ';');
// Comment := LineData;
PassQuota := Pos('(', DataBody) = 0;
// Split each item into TStrings.
repeat
if not PassQuota then begin
Inc(CurrentLineNum);
LineData := Trim(FileStrings.Strings[CurrentLineNum]);
DataBody := DataBody + ' ' + Fetch(LineData, ';');
PassQuota := Pos(')', DataBody) > 0;
end;
until PassQuota;
EachLinePart.Clear;
DataBody := ReplaceSpecString(DataBody, '(', '');
DataBody := ReplaceSpecString(DataBody, ')', '');
repeat
DataBody := Trim(DataBody);
FPart := Fetch(DataBody, #9);
repeat
FPart := Trim(FPart);
if Pos('"', FPart) = 1 then begin
Fetch(FPart, '"');
LText := Fetch(FPart, '"');
EachLinePart.Add(LText);
end;
LTag := Fetch(FPart, ' ');
if (TagList.IndexOf(LTag) = -1) and (LTag <> 'IN') then begin {do not localize}
LTag := LowerCase(LTag);
end;
if (LTag <> '') and (LTag <> '(') and (LTag <> ')') then begin
EachLinePart.Add(LTag);
end;
until FPart = '';
until DataBody = '';
if EachLinePart.Count > 0 then begin
if EachLinePart.Strings[0] = cOrigin then begin
// One Domain is found.
NewDomain := EachLinePart.Strings[1];
if TextEndsWith(NewDomain, '.') then begin
LastDenotedDomain := NewDomain;
NewDomain := '';
end else begin
LastDenotedDomain := NewDomain + '.' + LastDenotedDomain;
NewDomain := '';
end;
end else begin
// Search RR Type Tag;
Count := 0;
TagField := -1;
repeat
Found := TagList.IndexOf(EachLinePart.Strings[Count]) > -1;
if Found then begin
TagField := Count;
end;
Inc(Count);
until Found or (Count > (EachLinePart.Count-1));
// To initialize LastTTL;
LastTTL := 86400;
if TagField > -1 then begin
case TagField of
1 :
if EachLinePart.Strings[0] <> 'IN' then begin {do not localize}
// canChangPrevDNTag := True;
LastTag := EachLinePart.Strings[0];
if EachLinePart.Strings[TagField] <> 'SOA' then begin {do not localize}
// PrevDNTag := '';
end else begin
LastTTL := IndyStrToInt(EachLinePart.Strings[TagField + 6]);
end;
// end else begin
// canChangPrevDNTag := False;
end;
2 :
if EachLinePart.Strings[1] = 'IN' then begin {do not localize}
LastTag := EachLinePart.Strings[0];
// canChangPrevDNTag := True;
if EachLinePart.Strings[TagField] <> 'SOA' then begin {do not localize}
// PrevDNTag := '';
end else begin
LastTTL := IndyStrToInt(EachLinePart.Strings[TagField + 6]);
end;
end else begin
// canChangPrevDNTag := False;
end;
else
begin
// canChangPrevDNTag := False;
LastTTL := 86400;
end;
end;
//if (EachLinePart.Strings[0] = cAt) or (PrevDNTag = 'SOA') then
if EachLinePart.Strings[0] = cAt then begin
SingleHostName := LastDenotedDomain
end else begin
if LastTag = cAt then begin
LastTag := SingleHostName;
end;
if not TextEndsWith(LastTag, '.') then begin
SingleHostName := LastTag + '.' + LastDenotedDomain
end else begin
SingleHostName := LastTag;
end;
end;
case TagList.IndexOf(EachLinePart.Strings[TagField]) of
// Check ip
TypeCode_A :
begin
LLRR_A := TIdRR_A.Create;
LLRR_A.RRName := SingleHostName;
LLRR_A.Address := EachLinePart.Strings[TagField + 1];
LLRR_A.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_A);
// if canChangPrevDNTag then begin
// PrevDNTag := 'A';
// end;
end;
// Check IPv6 ip address 10/29,2002
0 :
begin
LLRR_AAAA := TIdRR_AAAA.Create;
LLRR_AAAA.RRName := SingleHostName;
LLRR_AAAA.Address := ConvertToValidv6IP(EachLinePart.Strings[TagField + 1]);
LLRR_AAAA.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_AAAA);
// if canChangPrevDNTag then begin
// PrevDNTag := 'AAAA'; {do not localize}
// end;
end;
// Check Domain Name
TypeCode_CName:
begin
LLRR_Name := TIdRR_CName.Create;
LLRR_Name.RRName := SingleHostName;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_Name.CName := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_Name.CName := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
LLRR_Name.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_Name);
// if canChangPrevDNTag then begin
// PrevDNTag := 'CNAME'; {do not localize}
// end;
end;
TypeCode_NS :
begin
LLRR_NS := TIdRR_NS.Create;
LLRR_NS.RRName := SingleHostName;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_NS.NSDName := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_NS.NSDName := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
LLRR_NS.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_NS);
// if canChangPrevDNTag then begin
// PrevDNTag := 'NS'; {do not localize}
// end;
end;
TypeCode_MR :
begin
LLRR_MR := TIdRR_MR.Create;
LLRR_MR.RRName := SingleHostName;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_MR.NewName := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_MR.NewName := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
LLRR_MR.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_MR);
// if canChangPrevDNTag then begin
// PrevDNTag := 'MR'; {do not localize}
// end;
end;
TypeCode_MD, TypeCode_MB, TypeCode_MF :
begin
LLRR_MB := TIdRR_MB.Create;
LLRR_MB.RRName := SingleHostName;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_MB.MADName := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_MB.MADName := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
LLRR_MB.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_MB);
// if canChangPrevDNTag then begin
// PrevDNTag := 'MF'; {do not localize}
// end;
end;
TypeCode_MG :
begin
LLRR_MG := TIdRR_MG.Create;
LLRR_MG.RRName := SingleHostName;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_MG.MGMName := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_MG.MGMName := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
LLRR_MG.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_MG);
// if canChangPrevDNTag then begin
// PrevDNTag := 'MG'; {do not localize}
// end;
end;
// Can be anything
TypeCode_TXT, TypeCode_NULL:
begin
LLRR_TXT := TIdRR_TXT.Create;
LLRR_TXT.RRName := SingleHostName;
LLRR_TXT.TXT := EachLinePart.Strings[TagField + 1];
LLRR_TXT.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_TXT);
// if canChangPrevDNTag then begin
// PrevDNTag := 'TXT'; {do not localize}
// end;
end;
// Must be FQDN.
TypeCode_PTR:
begin
LLRR_PTR := TIdRR_PTR.Create;
LLRR_PTR.RRName := SingleHostName;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_PTR.PTRDName := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_PTR.PTRDName := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
LLRR_PTR.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_PTR);
// if canChangPrevDNTag then begin
// PrevDNTag := 'PTR'; {do not localize}
// end;
end;
// HINFO should has 2 fields : CPU and OS. but TStrings
// is 0 base, so that we have to minus one
TypeCode_HINFO:
begin
ClearDoubleQutoa(EachLinePart);
LLRR_HINFO := TIdRR_HINFO.Create;
LLRR_HINFO.RRName := SingleHostName;
LLRR_HINFO.CPU := EachLinePart.Strings[TagField + 1];
LLRR_HINFO.OS := EachLinePart.Strings[TagField + 2];
LLRR_HINFO.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_HINFO);
// if canChangPrevDNTag then begin
// PrevDNTag := 'HINFO'; {do not localize}
// end;
end;
// Check RMailBX and EMailBX but TStrings
// is 0 base, so that we have to minus one
TypeCode_MINFO:
begin
LLRR_MINFO := TIdRR_MINFO.Create;
LLRR_MINFO.RRName := SingleHostName;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_MINFO.Responsible_Mail := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_MINFO.Responsible_Mail := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
if TextEndsWith(EachLinePart.Strings[TagField + 2], '.') then begin
LLRR_MINFO.ErrorHandle_Mail := EachLinePart.Strings[TagField + 2];
end else begin
LLRR_MINFO.ErrorHandle_Mail := EachLinePart.Strings[TagField + 2] + '.' + LastDenotedDomain;
end;
LLRR_MINFO.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_MINFO);
// if canChangPrevDNTag then begin
// PrevDNTag := 'MINFO'; {do not localize}
// end;
end;
// Check Pref(Numeric) and Exchange. but TStrings
// is 0 base, so that we have to minus one
TypeCode_MX:
begin
LLRR_MX := TIdRR_MX.Create;
LLRR_MX.RRName := SingleHostName;
LLRR_MX.Preference := EachLinePart.Strings[TagField + 1];
if TextEndsWith(EachLinePart.Strings[TagField + 2], '.') then begin
LLRR_MX.Exchange := EachLinePart.Strings[TagField + 2];
end else begin
LLRR_MX.Exchange := EachLinePart.Strings[TagField + 2] + '.' + LastDenotedDomain;
end;
LLRR_MX.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_MX);
// if canChangPrevDNTag then begin
// PrevDNTag := 'MX'; {do not localize}
// end;
end;
// TStrings is 0 base, so that we have to minus one
TypeCode_SOA:
begin
LLRR_SOA := TIdRR_SOA.Create;
if TextEndsWith(EachLinePart.Strings[TagField + 1], '.') then begin
LLRR_SOA.MName := EachLinePart.Strings[TagField + 1];
end else begin
LLRR_SOA.MName := EachLinePart.Strings[TagField + 1] + '.' + LastDenotedDomain;
end;
//LLRR_SOA.RRName:= LLRR_SOA.MName;
if (SingleHostName = '') and (LastDenotedDomain = '') then begin
{$IFDEF STRING_IS_UNICODE}
LastDenotedDomain := String(LLRR_SOA.MName); // explicit convert to Unicode
{$ELSE}
LastDenotedDomain := LLRR_SOA.MName;
{$ENDIF}
Fetch(LastDenotedDomain, '.');
SingleHostName := LastDenotedDomain;
end;
LLRR_SOA.RRName := SingleHostName;
// Update the Handed List
{
if Handed_DomainList.IndexOf(LLRR_SOA.MName) = -1 then begin
Handed_DomainList.Add(LLRR_SOA.MName);
end;
}
if Handed_DomainList.IndexOf(LLRR_SOA.RRName) = -1 then begin
Handed_DomainList.Add(LLRR_SOA.RRName);
end;
{
if DenotedDomain.IndexOf(LLRR_SOA.MName) = -1 then begin
DenotedDomain.Add(LLRR_SOA.MName);
end;
LastDenotedDomain := LLRR_SOA.MName;
}
if DenotedDomain.IndexOf(LLRR_SOA.RRName) = -1 then begin
DenotedDomain.Add(LLRR_SOA.RRName);
end;
//LastDenotedDomain := LLRR_SOA.RRName;
if TextEndsWith(EachLinePart.Strings[TagField + 2], '.') then begin
LLRR_SOA.RName := EachLinePart.Strings[TagField + 2];
end else begin
LLRR_SOA.RName := EachLinePart.Strings[TagField + 2] + '.' + LastDenotedDomain;
end;
Checks := TStringList.Create;
try
{$IFDEF STRING_IS_UNICODE}
RName := String(LLRR_SOA.RName); // explicit convert to Unicode
{$ELSE}
RName := LLRR_SOA.RName;
{$ENDIF}
while RName <> '' do begin
Checks.Add(Fetch(RName, '.'));
end;
RName := '';
For Count := 0 to Checks.Count -1 do begin
if Checks.Strings[Count] <> '' then begin
RName := RName + Checks.Strings[Count] + '.';
end;
end;
LLRR_SOA.RName := RName;
finally
FreeAndNil(Checks);
end;
LLRR_SOA.Serial := EachLinePart.Strings[TagField + 3];
LLRR_SOA.Refresh := EachLinePart.Strings[TagField + 4];
LLRR_SOA.Retry := EachLinePart.Strings[TagField + 5];
LLRR_SOA.Expire := EachLinePart.Strings[TagField + 6];
LLRR_SOA.Minimum := EachLinePart.Strings[TagField + 7];
LastTTL := IndyStrToInt(LLRR_SOA.Expire);
LLRR_SOA.TTL := LastTTL;
UpdateTree(TreeRoot, LLRR_SOA);
// if canChangPrevDNTag then begin
// PrevDNTag := 'SOA'; {do not localize}
// end;
end;
TypeCode_WKS:
begin
// if canChangPrevDNTag then begin
// PrevDNTag := 'WKS'; {do not localize}
// end;
end;
end;
end;
end; // if EachLinePart.Count == 0 => Only Comment
end;
Inc(CurrentLineNum);
until (CurrentLineNum > (FileStrings.Count -1));
end;
Result := not Stop;
finally
FreeAndNil(DenotedDomain);
end;
finally
FreeAndNil(EachLinePart);
end;
end;
begin
MakeTagList;
try
Result := IsValidMasterFile;
// IsValidMasterFile is used in local, so I design with not
// any parameter.
if Result then begin
Result := LoadMasterFile;
end;
finally
FreeTagList;
end;
end;
procedure TIdDNS_UDPServer.SaveToCache(ResourceRecord: TIdBytes; QueryName : string; OriginalQType : UInt16);
var
TempResolver : TIdDNSResolver;
Count : Integer;
begin
TempResolver := TIdDNSResolver.Create(nil);
try
// RLebeau: FillResultWithOutCheckId() is deprecated, but not using FillResult()
// here yet because it validates the DNSHeader.RCode, and I do not know if that
// is needed here. I don't want to break this logic...
TempResolver.FillResultWithOutCheckId(ResourceRecord);
if TempResolver.DNSHeader.ANCount > 0 then begin
for Count := 0 to TempResolver.QueryResult.Count - 1 do begin
UpdateTree(Cached_Tree, TempResolver.QueryResult.Items[Count]);
end;
end;
finally
FreeAndNil(TempResolver);
end;
end;
function TIdDNS_UDPServer.SearchTree(Root: TIdDNTreeNode; QName: String; QType : UInt16): TIdDNTreeNode;
var
RRIndex : integer;
NodeCursor : TIdDNTreeNode;
NameLabels : TStrings;
OneNode, FullName : string;
Found : Boolean;
begin
Result := nil;
NameLabels := TStringList.Create;
try
FullName := QName;
NodeCursor := Root;
Found := False;
repeat
OneNode := Fetch(FullName, '.');
if OneNode <> '' then begin
NameLabels.Add(OneNode);
end;
until FullName = '';
repeat
if QType <> TypeCode_SOA then begin
RRIndex := NodeCursor.ChildIndex.IndexOf(NameLabels.Strings[NameLabels.Count - 1]);
if RRIndex <> -1 then begin
NameLabels.Delete(NameLabels.Count - 1);
NodeCursor := NodeCursor.Children[RRIndex];
if NameLabels.Count = 1 then begin
Found := NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1;
end else begin
Found := NameLabels.Count = 0;
end;
end else begin
if NameLabels.Count = 1 then begin
Found := NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1;
if not Found then begin
NameLabels.Clear;
end;
end else begin
NameLabels.Clear;
end;
end;
end else begin
RRIndex := NodeCursor.ChildIndex.IndexOf(NameLabels.Strings[NameLabels.Count - 1]);
if RRIndex <> -1 then begin
NameLabels.Delete(NameLabels.Count - 1);
NodeCursor := NodeCursor.Children[RRIndex];
if NameLabels.Count = 1 then begin
Found := NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1;
end else begin
Found := NameLabels.Count = 0;
end;
end else begin
if NameLabels.Count = 1 then begin
Found := NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1;
if not Found then begin
NameLabels.Clear;
end;
end else begin
NameLabels.Clear;
end;
end;
end;
until (NameLabels.Count = 0) or Found;
if Found then begin
Result := NodeCursor;
end;
finally
FreeAndNil(NameLabels);
end;
end;
procedure TIdDNS_UDPServer.SetHanded_DomainList(const Value: TStrings);
begin
FHanded_DomainList.Assign(Value);
end;
procedure TIdDNS_UDPServer.SetRootDNS_NET(const Value: TStrings);
begin
FRootDNS_NET.Assign(Value);
end;
procedure TIdDNS_UDPServer.SetZoneMasterFiles(const Value: TStrings);
begin
FZoneMasterFiles.Assign(Value);
end;
procedure TIdDNS_UDPServer.UpdateTree(TreeRoot: TIdDNTreeNode; RR: TResultRecord);
var
NameNode : TStrings;
RRName, APart : String;
Count, NodeIndex : Integer;
NodeCursor : TIdDNTreeNode;
LRR_A : TIdRR_A;
LRR_AAAA : TIdRR_AAAA;
LRR_NS : TIdRR_NS;
LRR_MB : TIdRR_MB;
LRR_Name : TIdRR_CName;
LRR_SOA : TIdRR_SOA;
LRR_MG : TIdRR_MG;
LRR_MR : TIdRR_MR;
LRR_PTR : TIdRR_PTR;
LRR_HINFO : TIdRR_HINFO;
LRR_MINFO : TIdRR_MINFO;
LRR_MX : TIdRR_MX;
LRR_TXT : TIdRR_TXT;
begin
RRName := RR.Name;
NameNode := TStringList.Create;
try
repeat
APart := Fetch(RRName, '.');
if APart <> '' then begin
NameNode.Add(APart);
end;
until RRName = '';
NodeCursor := TreeRoot;
RRName := RR.Name;
if not TextEndsWith(RRName, '.') then begin
RRName := RRName + '.';
end;
if (RR.RecType <> qtSOA) and (Handed_DomainList.IndexOf(LowerCase(RRName)) = -1) and (RR.RecType <> qtNS) then begin
for Count := NameNode.Count-1 downto 1 do begin
NodeIndex := NodeCursor.ChildIndex.IndexOf(NameNode.Strings[Count]);
if NodeIndex = -1 then begin
NodeCursor := NodeCursor.AddChild;
NodeCursor.AutoSortChild := True;
NodeCursor.CLabel := NameNode.Strings[Count];
end else begin
NodeCursor := NodeCursor.Children[NodeIndex];
end;
end;
RRName := NameNode.Strings[0];
end else begin
for Count := NameNode.Count-1 downto 0 do begin
NodeIndex := NodeCursor.ChildIndex.IndexOf(NameNode.Strings[Count]);
RRName := NameNode.Strings[Count];
if NodeIndex = -1 then begin
NodeCursor := NodeCursor.AddChild;
//NodeCursor.CLabel := RRName;
NodeCursor.AutoSortChild := True;
NodeCursor.CLabel := RRName;
end else begin
NodeCursor := NodeCursor.Children[NodeIndex];
end;
end;
RRName := RR.Name;
end;
NodeCursor.RRs.ItemNames.Add(RRName);
case RR.RecType of
qtA :
begin
LRR_A := TIdRR_A.Create;
try
NodeCursor.RRs.Add(LRR_A);
except
LRR_A.Free;
raise;
end;
LRR_A.RRName := RRName;
LRR_A.Address := TARecord(RR).IPAddress;
LRR_A.TTL := TARecord(RR).TTL;
if LRR_A.ifAddFullName(NodeCursor.FullName) then begin
LRR_A.RRName := LRR_A.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtAAAA :
begin
LRR_AAAA := TIdRR_AAAA.Create;
try
NodeCursor.RRs.Add(LRR_AAAA);
except
LRR_AAAA.Free;
raise;
end;
LRR_AAAA.RRName := RRName;
LRR_AAAA.Address := TAAAARecord(RR).Address;
LRR_AAAA.TTL := TAAAARecord(RR).TTL;
if LRR_AAAA.ifAddFullName(NodeCursor.FullName) then begin
LRR_AAAA.RRName := LRR_AAAA.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtNS:
begin
LRR_NS := TIdRR_NS.Create;
try
NodeCursor.RRs.Add(LRR_NS);
except
LRR_NS.Free;
raise;
end;
LRR_NS.RRName := RRName;
LRR_NS.NSDName := TNSRecord(RR).HostName;
LRR_NS.TTL := TNSRecord(RR).TTL;
if LRR_NS.ifAddFullName(NodeCursor.FullName) then begin
LRR_NS.RRName := LRR_NS.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtMD, qtMF, qtMB:
begin
LRR_MB := TIdRR_MB.Create;
try
NodeCursor.RRs.Add(LRR_MB);
except
LRR_MB.Free;
raise;
end;
LRR_MB.RRName := RRName;
LRR_MB.MADName := TNAMERecord(RR).HostName;
LRR_MB.TTL := TNAMERecord(RR).TTL;
if LRR_MB.ifAddFullName(NodeCursor.FullName) then begin
LRR_MB.RRName := LRR_MB.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtName:
begin
LRR_Name := TIdRR_CName.Create;
try
NodeCursor.RRs.Add(LRR_Name);
except
LRR_Name.Free;
raise;
end;
LRR_Name.RRName := RRName;
LRR_Name.CName := TNAMERecord(RR).HostName;
LRR_Name.TTL:= TNAMERecord(RR).TTL;
if LRR_Name.ifAddFullName(NodeCursor.FullName) then begin
LRR_Name.RRName := LRR_Name.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtSOA:
begin
LRR_SOA := TIdRR_SOA.Create;
try
NodeCursor.RRs.Add(LRR_SOA);
except
LRR_SOA.Free;
raise;
end;
LRR_SOA.RRName := RRName;
LRR_SOA.MName := TSOARecord(RR).Primary;
LRR_SOA.RName := TSOARecord(RR).ResponsiblePerson;
LRR_SOA.Serial := IntToStr(TSOARecord(RR).Serial);
LRR_SOA.Minimum := IntToStr(TSOARecord(RR).MinimumTTL);
LRR_SOA.Refresh := IntToStr(TSOARecord(RR).Refresh);
LRR_SOA.Retry := IntToStr(TSOARecord(RR).Retry);
LRR_SOA.Expire := IntToStr(TSOARecord(RR).Expire);
LRR_SOA.TTL:= TSOARecord(RR).TTL;
if LRR_SOA.ifAddFullName(NodeCursor.FullName) then begin
LRR_SOA.RRName := LRR_SOA.RRName + '.'+ NodeCursor.FullName;
end
else if not TextEndsWith(LRR_SOA.RRName, '.') then begin
LRR_SOA.RRName := LRR_SOA.RRName + '.';
end;
end;
qtMG :
begin
LRR_MG := TIdRR_MG.Create;
try
NodeCursor.RRs.Add(LRR_MG);
except
LRR_MG.Free;
raise;
end;
LRR_MG.RRName := RRName;
LRR_MG.MGMName := TNAMERecord(RR).HostName;
LRR_MG.TTL := TNAMERecord(RR).TTL;
if LRR_MG.ifAddFullName(NodeCursor.FullName) then begin
LRR_MG.RRName := LRR_MG.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtMR :
begin
LRR_MR := TIdRR_MR.Create;
try
NodeCursor.RRs.Add(LRR_MR);
except
LRR_MR.Free;
raise;
end;
LRR_MR.RRName := RRName;
LRR_MR.NewName := TNAMERecord(RR).HostName;
LRR_MR.TTL := TNAMERecord(RR).TTL;
if LRR_MR.ifAddFullName(NodeCursor.FullName) then begin
LRR_MR.RRName := LRR_MR.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtWKS:
begin
end;
qtPTR:
begin
LRR_PTR := TIdRR_PTR.Create;
try
NodeCursor.RRs.Add(LRR_PTR);
except
LRR_PTR.Free;
raise;
end;
LRR_PTR.RRName := RRName;
LRR_PTR.PTRDName := TPTRRecord(RR).HostName;
LRR_PTR.TTL := TPTRRecord(RR).TTL;
if LRR_PTR.ifAddFullName(NodeCursor.FullName) then begin
LRR_PTR.RRName := LRR_PTR.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtHINFO:
begin
LRR_HINFO := TIdRR_HINFO.Create;
try
NodeCursor.RRs.Add(LRR_HINFO);
except
LRR_HINFO.Free;
raise;
end;
LRR_HINFO.RRName := RRName;
LRR_HINFO.CPU := THINFORecord(RR).CPU;
LRR_HINFO.OS := THINFORecord(RR).OS;
LRR_HINFO.TTL := THINFORecord(RR).TTL;
if LRR_HINFO.ifAddFullName(NodeCursor.FullName) then begin
LRR_HINFO.RRName := LRR_HINFO.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtMINFO:
begin
LRR_MINFO := TIdRR_MINFO.Create;
try
NodeCursor.RRs.Add(LRR_MINFO);
except
LRR_MINFO.Free;
raise;
end;
LRR_MINFO.RRName := RRName;
LRR_MINFO.Responsible_Mail := TMINFORecord(RR).ResponsiblePersonMailbox;
LRR_MINFO.ErrorHandle_Mail := TMINFORecord(RR).ErrorMailbox;
LRR_MINFO.TTL := TMINFORecord(RR).TTL;
if LRR_MINFO.ifAddFullName(NodeCursor.FullName) then begin
LRR_MINFO.RRName := LRR_MINFO.RRName + '.' + NodeCursor.FullName;
end;
end;
qtMX:
begin
LRR_MX := TIdRR_MX.Create;
try
NodeCursor.RRs.Add(LRR_MX);
except
LRR_MX.Free;
raise;
end;
LRR_MX.RRName := RRName;
LRR_MX.Exchange := TMXRecord(RR).ExchangeServer;
LRR_MX.Preference := IntToStr(TMXRecord(RR).Preference);
LRR_MX.TTL := TMXRecord(RR).TTL;
if LRR_MX.ifAddFullName(NodeCursor.FullName) then begin
LRR_MX.RRName := LRR_MX.RRName + '.'+ NodeCursor.FullName;
end;
end;
qtTXT, qtNULL:
begin
LRR_TXT := TIdRR_TXT.Create;
try
NodeCursor.RRs.Add(LRR_TXT);
except
LRR_TXT.Free;
raise;
end;
LRR_TXT.RRName := RRName;
LRR_TXT.TXT := TTextRecord(RR).Text.Text;
LRR_TXT.TTL := TTextRecord(RR).TTL;
if LRR_TXT.ifAddFullName(NodeCursor.FullName) then begin
LRR_TXT.RRName := LRR_TXT.RRName + '.'+ NodeCursor.FullName;
end;
end;
end;
finally
FreeAndNil(NameNode);
end;
end;
procedure TIdDNS_UDPServer.UpdateTree(TreeRoot: TIdDNTreeNode; RR: TIdTextModeResourceRecord);
var
NameNode : TStrings;
RRName, APart : String;
Count, NodeIndex, RRIndex : Integer;
NodeCursor : TIdDNTreeNode;
LRR_AAAA : TIdRR_AAAA;
LRR_A : TIdRR_A;
LRR_NS : TIdRR_NS;
LRR_MB : TIdRR_MB;
LRR_Name : TIdRR_CName;
LRR_SOA : TIdRR_SOA;
LRR_MG : TIdRR_MG;
LRR_MR : TIdRR_MR;
LRR_PTR : TIdRR_PTR;
LRR_HINFO : TIdRR_HINFO;
LRR_MINFO : TIdRR_MINFO;
LRR_MX : TIdRR_MX;
LRR_TXT : TIdRR_TXT;
LRR_Error : TIdRR_Error;
begin
RRName := RR.RRName;
NameNode := TStringList.Create;
try
repeat
APart := Fetch(RRName, '.');
if APart <> '' then begin
NameNode.Add(APart);
end;
until RRName = '';
NodeCursor := TreeRoot;
RRName := RR.RRName;
if not TextEndsWith(RRName, '.') then begin
RR.RRName := RR.RRName + '.';
end;
// VC: in2002-02-24-1715, it just denoted TIdRR_A and TIdRR_PTR,
// but that make search a domain name RR becoming complex,
// therefor I replace it with all RRs but not TIdRR_SOA
// SOA should own independent node.
if (not (RR is TIdRR_SOA)) and (Handed_DomainList.IndexOf(LowerCase(RR.RRName)) = -1) then begin
for Count := NameNode.Count - 1 downto 1 do begin
NodeIndex := NodeCursor.ChildIndex.IndexOf(NameNode.Strings[Count]);
if NodeIndex = -1 then begin
NodeCursor := NodeCursor.AddChild;
NodeCursor.AutoSortChild := True;
NodeCursor.CLabel := NameNode.Strings[Count];
end else begin
NodeCursor := NodeCursor.Children[NodeIndex];
end;
end;
RRName := NameNode.Strings[0];
end else begin
for Count := NameNode.Count -1 downto 0 do begin
NodeIndex := NodeCursor.ChildIndex.IndexOf(NameNode.Strings[Count]);
RRName := NameNode.Strings[Count];
if NodeIndex = -1 then begin
NodeCursor := NodeCursor.AddChild;
NodeCursor.AutoSortChild := True;
NodeCursor.CLabel := RRName;
end else begin
NodeCursor := NodeCursor.Children[NodeIndex];
end;
end;
RRName := RR.RRName;
end;
RRIndex := NodeCursor.RRs.ItemNames.IndexOf(RRName);
if RRIndex = -1 then begin
NodeCursor.RRs.ItemNames.Add(RRName);
end else begin
repeat
Inc(RRIndex);
if RRIndex > NodeCursor.RRs.ItemNames.Count -1 then begin
RRIndex := -1;
Break;
end;
if NodeCursor.RRs.ItemNames.Strings[RRIndex] <> RRName then begin
Break;
end;
until RRIndex > (NodeCursor.RRs.ItemNames.Count-1);
if RRIndex = -1 then begin
NodeCursor.RRs.ItemNames.Add(RRName);
end else begin
NodeCursor.RRs.ItemNames.Insert(RRIndex, RRName);
end;
end;
case RR.TypeCode of
TypeCode_Error :
begin
LRR_Error := TIdRR_Error(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_Error);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_Error);
end;
end;
TypeCode_A :
begin
LRR_A := TIdRR_A(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_A);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_A);
end;
end;
TypeCode_AAAA :
begin
LRR_AAAA := TIdRR_AAAA(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_AAAA);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_AAAA);
end;
end;
TypeCode_NS:
begin
LRR_NS := TIdRR_NS(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_NS);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_NS);
end;
end;
TypeCode_MF:
begin
LRR_MB := TIdRR_MB(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_MB);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_MB);
end;
end;
TypeCode_CName:
begin
LRR_Name := TIdRR_CName(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_Name);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_Name);
end;
end;
TypeCode_SOA:
begin
LRR_SOA := TIdRR_SOA(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_SOA);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_SOA);
end;
end;
TypeCode_MG :
begin
LRR_MG := TIdRR_MG(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_MG);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_MG);
end;
end;
TypeCode_MR :
begin
LRR_MR := TIdRR_MR(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_MR);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_MR);
end;
end;
TypeCode_WKS:
begin
end;
TypeCode_PTR:
begin
LRR_PTR := TIdRR_PTR(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_PTR);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_PTR);
end;
end;
TypeCode_HINFO:
begin
LRR_HINFO := TIdRR_HINFO(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_HINFO);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_HINFO);
end;
end;
TypeCode_MINFO:
begin
LRR_MINFO := TIdRR_MINFO(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_MINFO);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_MINFO);
end;
end;
TypeCode_MX:
begin
LRR_MX := TIdRR_MX(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_MX);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_MX);
end;
end;
TypeCode_TXT, TypeCode_NULL:
begin
LRR_TXT := TIdRR_TXT(RR);
if RRIndex = -1 then begin
NodeCursor.RRs.Add(LRR_TXT);
end else begin
NodeCursor.RRs.Insert(RRIndex, LRR_TXT);
end;
end;
end;
finally
FreeAndNil(NameNode);
end;
end;
procedure TIdDNS_UDPServer.DoAfterSendBack(ABinding: TIdSocketHandle;
ADNSHeader: TDNSHeader; var QueryResult: TIdBytes; var ResultCode: String;
Query : TIdBytes);
begin
if Assigned(FOnAfterSendBack) then begin
FOnAfterSendBack(ABinding, ADNSHeader, QueryResult, ResultCode, Query);
end;
end;
function TIdDNS_UDPServer.AXFR(Header : TDNSHeader; Question: string; var Answer: TIdBytes): string;
var
TargetNode : TIdDNTreeNode;
IsMyDomains : Boolean;
RRcount : Integer;
Temp: TIdBytes;
begin
Question := LowerCase(Question);
IsMyDomains := Handed_DomainList.IndexOf(Question) > -1;
if not IsMyDomains then begin
Fetch(Question, '.');
IsMyDomains := Handed_DomainList.IndexOf(Question) > -1;
end;
// Is my domain, go for searching the node.
TargetNode := nil;
SetLength(Answer, 0);
Header.ANCount := 0;
if IsMyDomains then begin
TargetNode := SearchTree(Handed_Tree, Question, TypeCode_SOA);
end;
if IsMyDomains and (TargetNode <> nil) then begin
// combine the AXFR Data(So many)
RRCount := 0;
Answer := TargetNode.DumpAllBinaryData(RRCount);
Header.ANCount := RRCount;
Header.QR := iQr_Answer;
Header.AA := iAA_Authoritative;
Header.RCode := iRCodeNoError;
Header.QDCount := 0;
Header.ARCount := 0;
Header.TC := 0;
Temp := Header.GenerateBinaryHeader;
AppendBytes(Temp, Answer);
Answer := Temp;
Result := cRCodeQueryOK;
end else begin
Header.QR := iQr_Answer;
Header.AA := iAA_Authoritative;
Header.RCode := iRCodeNameError;
Header.QDCount := 0;
Header.ARCount := 0;
Header.TC := 0;
Answer := Header.GenerateBinaryHeader;
Result := cRCodeQueryNotFound;
end;
end;
procedure TIdDNS_UDPServer.InternalSearch(Header: TDNSHeader; QName: string;
QType : UInt16; var Answer: TIdBytes; IfMainQuestion : Boolean;
IsSearchCache : Boolean = False; IsAdditional : Boolean = False;
IsWildCard : Boolean = False; WildCardOrgName : string = '');
var
MoreAddrSearch : TStrings;
TargetNode : TIdDNTreeNode;
Server_Index, RRIndex, Count : Integer;
LocalAnswer, TempBytes, TempAnswer: TIdBytes;
temp_QName, temp: string;
AResult: TIdBytes;
Stop, Extra, IsMyDomains, ifAdditional : Boolean;
LDNSResolver : TIdDNSResolver;
procedure CheckMoreAddrSearch(const AStr: String);
begin
if (not IsValidIP(AStr)) and IsHostName(AStr) then begin
MoreAddrSearch.Add(AStr);
end;
end;
begin
SetLength(Answer, 0);
SetLength(Aresult, 0);
// Search the Handed Tree first.
MoreAddrSearch := TStringList.Create;
try
Extra := False;
//Pushed := False;
if not IsSearchCache then begin
TargetNode := SearchTree(Handed_Tree, QName, QType);
if TargetNode <> nil then begin //Assemble the Answer.
RRIndex := TargetNode.RRs.ItemNames.IndexOf(LowerCase(QName));
if RRIndex = -1 then begin
{ below are added again by Dennies Chang in 2004/7/15
{ According RFC 1035, a full domain name must be tailed by a '.',
{ but in normal behavior, user will not input '.' in last
{ position of the full name. So we have to compare both of the
{ cases. }
if TextEndsWith(QName, '.') then begin
QName := Copy(QName, 1, Length(QName)-1);
end;
RRIndex := TargetNode.RRs.ItemNames.IndexOf(LowerCase(QName));
{ above are added again by Dennies Chang in 2004/7/15}
if RRIndex = -1 then begin
QName := Fetch(QName, '.');
RRIndex := TargetNode.RRs.ItemNames.IndexOf(LowerCase(QName));
end;
{ marked by Dennies Chang in 2004/7/15
QName:= Fetch(QName, '.');
RRIndex := TargetNode.RRs.ItemNames.IndexOf(IndyLowerCase(QName));
}
end;
repeat
temp_QName := QName;
SetLength(LocalAnswer, 0);
if RRIndex <> -1 then begin
case QType of
TypeCode_A:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_A then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_AAAA:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_AAAA then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_NS:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_NS then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_NS).NSDName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MD:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MB then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MB).MADName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MF:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MB then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MB).MADName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_CName:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_CName then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_CName).CName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_SOA:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_SOA then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_SOA).MName);
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_SOA).RName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MB:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MB then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MB).MADName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MG:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MG then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MG).MGMName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MR:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MR then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MR).NewName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_NULL:
begin
{
if TargetNode.RRs.Items[RRIndex] is TIdRR_NULL then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
}
end;
TypeCode_WKS:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_WKS then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_PTR:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_PTR then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_HINFO:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_HINFO then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MINFO:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MINFO then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MX:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MX then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MX).Exchange);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_TXT:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_TXT then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_STAR:
begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
if IsWildCard and (Length(LocalAnswer) > 0) then begin
{
temp := DomainNameToDNSStr(QName+'.'+TargetNode.FullName);
Fetch(LocalAnswer, temp);
}
TempBytes := DomainNameToDNSStr(TargetNode.FullName);
FetchBytes(LocalAnswer, TempBytes);
TempBytes := DomainNameToDNSStr(WildCardOrgName);
AppendBytes(TempBytes, LocalAnswer);
LocalAnswer := TempBytes;
//LocalAnswer := DomainNameToDNSStr(WildCardOrgName) + LocalAnswer;
end;
if Length(LocalAnswer) > 0 then begin
AppendBytes(Answer, LocalAnswer);
if ((not Extra) and (not IsAdditional)) or (QType = TypeCode_AAAA) then begin
if (TargetNode.RRs.Items[RRIndex] is TIdRR_NS) then begin
if IfMainQuestion then begin
Header.ANCount := Header.ANCount + 1;
end else begin
Header.NSCount := Header.NSCount + 1;
end;
end
else if IfMainQuestion then begin
Header.ANCount := Header.ANCount + 1;
end else begin
Header.ARCount := Header.ARCount + 1;
end;
end
else if IsAdditional then begin
Header.ARCount := Header.ARCount + 1;
end
else begin
Header.ANCount := Header.ANCount + 1;
end;
Header.Qr := iQr_Answer;
Header.AA := iAA_Authoritative;
Header.RCode := iRCodeNoError;
end;
if RRIndex < (TargetNode.RRs.ItemNames.Count-1) then begin
Stop := False;
Inc(RRIndex);
end else begin
Stop := True;
end;
end else begin
Stop := True;
end;
if QName = temp_QName then begin
temp_QName := '';
end;
until (RRIndex = -1) or
(not ((not TextIsSame(TargetNode.RRs.ItemNames.Strings[RRIndex], QName)) xor
(not TextIsSame(TargetNode.RRs.ItemNames.Strings[RRIndex], Fetch(temp_QName, '.')))))
or Stop;
// Finish the Loop, but n record is found, we need to search if
// there is a widechar record in its subdomain.
// Main, Cache, Additional, Wildcard
if Length(Answer) > 0 then begin
InternalSearch(Header, '*.' + QName, QType, LocalAnswer, IfMAinQuestion, False, False, True, QName);
if LocalAnswer <> nil then begin
AppendBytes(Answer, LocalAnswer);
end;
end;
end else begin // Node can't be found.
MoreAddrSearch.Clear;
end;
if MoreAddrSearch.Count > 0 then begin
for Count := 0 to MoreAddrSearch.Count -1 do begin
Server_Index := 0;
if Handed_DomainList.Count > 0 then begin
repeat
IsMyDomains := IndyPos(
LowerCase(Handed_DomainList.Strings[Server_Index]),
LowerCase(MoreAddrSearch.Strings[Count])) > 0;
Inc(Server_Index);
until IsMyDomains or (Server_Index > (Handed_DomainList.Count-1));
end else begin
IsMyDomains := False;
end;
if IsMyDomains then begin
//ifAdditional := (QType <> TypeCode_A) or (QType <> TypeCode_AAAA);
// modified by Dennies Chang in 2004/7/15.
ifAdditional := (QType <> TypeCode_CName);
//Search A record first.
// Main, Cache, Additional, Wildcard
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_A, LocalAnswer, True, False, ifAdditional, False);
{ modified by Dennies Chang in 2004/7/15.
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_A,
LocalAnswer, True, ifAdditional, True);
}
if Length(LocalAnswer) = 0 then begin
temp := MoreAddrSearch.Strings[Count];
Fetch(temp, '.');
temp := '*.' + temp;
InternalSearch(Header, temp, TypeCode_A, LocalAnswer, True, False, ifAdditional, True, MoreAddrSearch.Strings[Count]);
{ marked by Dennies Chang in 2004/7/15.
InternalSearch(Header, temp, TypeCode_A, LocalAnswer, True, ifAdditional, True, True, MoreAddrSearch.Strings[Count]);
}
end;
TempAnswer := LocalAnswer;
// Search for AAAA also.
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_AAAA, LocalAnswer, True, False, ifAdditional, True);
{ marked by Dennies Chang in 2004/7/15.
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_AAAA, LocalAnswer, True, ifAdditional, True);
}
if Length(LocalAnswer) = 0 then begin
temp := MoreAddrSearch.Strings[Count];
Fetch(temp, '.');
temp := '*.' + temp;
InternalSearch(Header, temp, TypeCode_AAAA, LocalAnswer, True, False, ifAdditional, True, MoreAddrSearch.Strings[Count]);
{ marked by Dennies Chang in 2004/7/15.
InternalSearch(Header, temp, TypeCode_AAAA, LocalAnswer, True, ifAdditional, True, True, MoreAddrSearch.Strings[Count]);
}
end;
AppendBytes(TempAnswer, LocalAnswer);
LocalAnswer := TempAnswer;
end else begin
// Need add AAAA Search in future.
//QType := TypeCode_A;
LDNSResolver := TIdDNSResolver.Create(Self);
try
Server_Index := 0;
repeat
LDNSResolver.Host := RootDNS_NET.Strings[Server_Index];
LDNSResolver.QueryType := [qtA];
LDNSResolver.Resolve(MoreAddrSearch.Strings[Count]);
AResult := LDNSResolver.PlainTextResult;
Header.ARCount := Header.ARCount + LDNSResolver.QueryResult.Count;
until (Server_Index >= (RootDNS_NET.Count-1)) or (Length(AResult) > 0);
AppendBytes(LocalAnswer, AResult, 12);
finally
FreeAndNil(LDNSResolver);
end;
end;
if Length(LocalAnswer) > 0 then begin
AppendBytes(Answer, LocalAnswer);
end;
//Answer := LocalAnswer;
end;
end;
end else begin
//Search the Cache Tree;
{ marked by Dennies Chang in 2004/7/15.
{ it's mark for querying cache only.
{ if Length(Answer) = 0 then begin }
TargetNode := SearchTree(Cached_Tree, QName, QType);
if TargetNode <> nil then begin
//Assemble the Answer.
{ modified by Dennies Chang in 2004/7/15}
if (QType in [TypeCode_A, TypeCode_PTR, TypeCode_AAAA, TypeCode_Error, TypeCode_CName]) then begin
QName := Fetch(QName, '.');
end;
RRIndex := TargetNode.RRs.ItemNames.IndexOf(QName);
repeat
temp_QName := QName;
SetLength(LocalAnswer, 0);
if RRIndex <> -1 then begin
// TimeOut, update the record.
if CompareDate(Now, StrToDateTime(TargetNode.RRs.Items[RRIndex].TimeOut)) = 1 then begin
SetLength(LocalAnswer, 0);
end else begin
case QType of
TypeCode_Error:
begin
AppendString(Answer, 'Error'); {do not localize}
end;
TypeCode_A:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_A then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_AAAA:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_AAAA then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_NS:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_NS then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_NS).NSDName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MD:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MB then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MB).MADName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MF:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MB then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MB).MADName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_CName:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_CName then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_CName).CName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_SOA:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_SOA then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_SOA).MName);
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_SOA).RName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MB:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MB then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MB).MADName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MG:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MG then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MG).MGMName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MR:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MR then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MR).NewName);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_NULL:
begin
{
if TargetNode.RRs.Items[RRIndex] is TIdRR_NULL then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
}
end;
TypeCode_WKS:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_WKS then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_PTR:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_PTR then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_HINFO:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_HINFO then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MINFO:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MINFO then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_MX:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_MX then begin
CheckMoreAddrSearch((TargetNode.RRs.Items[RRIndex] as TIdRR_MX).Exchange);
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_TXT:
begin
if TargetNode.RRs.Items[RRIndex] is TIdRR_TXT then begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
TypeCode_STAR:
begin
LocalAnswer := TargetNode.RRs.Items[RRIndex].BinQueryRecord(TargetNode.FullName);
end;
end;
end;
if BytesToString(LocalAnswer) = 'Error' then begin {do not localize}
Stop := True;
end else begin
if Length(LocalAnswer) > 0 then begin
AppendBytes(Answer, LocalAnswer);
if TargetNode.RRs.Items[RRIndex] is TIdRR_NS then begin
if IfMainQuestion then begin
Header.ANCount := Header.ANCount + 1;
end else begin
Header.NSCount := Header.NSCount + 1;
end;
end
else if IfMainQuestion then begin
Header.ANCount := Header.ANCount + 1;
end
else begin
Header.ARCount := Header.ARCount + 1;
end;
Header.Qr := iQr_Answer;
Header.AA := iAA_NotAuthoritative;
Header.RCode := iRCodeNoError;
end;
if RRIndex < (TargetNode.RRs.ItemNames.Count-1) then begin
Stop := False;
Inc(RRIndex);
end else begin
Stop := True;
end;
end;
end else begin
Stop := True;
end;
until (RRIndex = -1) or
(not ((not TextIsSame(TargetNode.RRs.ItemNames.Strings[RRIndex], QName)) xor
(not TextIsSame(TargetNode.RRs.ItemNames.Strings[RRIndex], Fetch(temp_QName, '.')))))
or Stop;
end;
// Search MoreAddrSearch it's added in 2004/7/15, but the need is
// found in 2004 Feb.
if MoreAddrSearch.Count > 0 then begin
for Count := 0 to MoreAddrSearch.Count -1 do begin
Server_Index := 0;
if Handed_DomainList.Count > 0 then begin
repeat
IsMyDomains := IndyPos(
LowerCase(Handed_DomainList.Strings[Server_Index]),
LowerCase(MoreAddrSearch.Strings[Count])) > 0;
Inc(Server_Index);
until IsMyDomains or (Server_Index > (Handed_DomainList.Count-1));
end else begin
IsMyDomains := False;
end;
if IsMyDomains then begin
ifAdditional := (QType <> TypeCode_A) or (QType <> TypeCode_AAAA);
//Search A record first.
// Main, Cache, Additional, Wildcard
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_A, LocalAnswer, True, False, ifAdditional, False);
if Length(LocalAnswer) = 0 then begin
temp := MoreAddrSearch.Strings[Count];
Fetch(temp, '.');
temp := '*.' + temp;
InternalSearch(Header, temp, TypeCode_A, LocalAnswer, True, False, ifAdditional, True, MoreAddrSearch.Strings[Count]);
end;
TempAnswer := LocalAnswer;
// Search for AAAA also.
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_AAAA, LocalAnswer, True, False, ifAdditional, True);
if Length(LocalAnswer) = 0 then begin
temp := MoreAddrSearch.Strings[Count];
Fetch(temp, '.');
temp := '*.' + temp;
InternalSearch(Header, temp, TypeCode_AAAA, LocalAnswer, True, False, ifAdditional, True, MoreAddrSearch.Strings[Count]);
end;
AppendBytes(TempAnswer, LocalAnswer);
LocalAnswer := TempAnswer;
end else begin
// §äCache
TempAnswer := LocalAnswer;
ifAdditional := (QType <> TypeCode_A) or (QType <> TypeCode_AAAA);
//Search A record first.
// Main, Cache, Additional, Wildcard
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_A, LocalAnswer, True, True, ifAdditional, False);
if Length(LocalAnswer) = 0 then begin
temp := MoreAddrSearch.Strings[Count];
Fetch(temp, '.');
temp := '*.' + temp;
InternalSearch(Header, temp, TypeCode_A, LocalAnswer, True, True, ifAdditional, True, MoreAddrSearch.Strings[Count]);
end;
AppendBytes(TempAnswer, LocalAnswer);
LocalAnswer := TempAnswer;
// Search for AAAA also.
InternalSearch(Header, MoreAddrSearch.Strings[Count], TypeCode_AAAA, LocalAnswer, True, True, ifAdditional, True);
if Length(LocalAnswer) > 0 then begin
AppendBytes(TempAnswer, LocalAnswer);
LocalAnswer := TempAnswer;
end;
Answer := LocalAnswer;
end;
end;
end;
end;
finally
FreeAndNil(MoreAddrSearch);
end;
end;
{ TIdDNSServer }
procedure TIdDNSServer.CheckIfExpire(Sender: TObject);
begin
end;
procedure TIdDNSServer.InitComponent;
begin
inherited InitComponent;
FAccessList := TStringList.Create;
FUDPTunnel := TIdDNS_UDPServer.Create(Self);
FTCPTunnel := TIdDNS_TCPServer.Create(Self);
FBindings := TIdSocketHandles.Create(Self);
FTCPTunnel.DefaultPort := IdPORT_DOMAIN;
FUDPTunnel.DefaultPort := IdPORT_DOMAIN;
ServerType := stPrimary;
BackupDNSMap := TIdDNSMap.Create(FUDPTunnel);
end;
destructor TIdDNSServer.Destroy;
begin
FreeAndNil(FAccessList);
FreeAndNil(FUDPTunnel);
FreeAndNil(FTCPTunnel);
FreeAndNil(FBindings);
FreeAndNil(BackupDNSMap);
inherited Destroy;
end;
procedure TIdDNSServer.SetAccessList(const Value: TStrings);
begin
FAccessList.Assign(Value);
FTCPTunnel.AccessList.Assign(Value);
end;
procedure TIdDNSServer.SetActive(const Value: Boolean);
var
Count : Integer;
DNSMap : TIdDomainNameServerMapping;
begin
FActive := Value;
FUDPTunnel.Active := Value;
if ServerType = stSecondary then begin
TCPTunnel.Active := False;
// TODO: should this loop only be run if Value=True?
for Count := 0 to BackupDNSMap.Count-1 do begin
DNSMap := BackupDNSMap.Items[Count];
DNSMap.CheckScheduler.Start;
end;
end else begin
TCPTunnel.Active := Value;
end;
end;
procedure TIdDNSServer.SetBindings(const Value: TIdSocketHandles);
begin
FBindings.Assign(Value);
FUDPTunnel.Bindings.Assign(Value);
FTCPTunnel.Bindings.Assign(Value);
end;
procedure TIdDNSServer.SetTCPACLActive(const Value: Boolean);
begin
FTCPACLActive := Value;
TCPTunnel.AccessControl := Value;
if Value then begin
FTCPTunnel.FAccessList.Assign(FAccessList);
end else begin
FTCPTunnel.FAccessList.Clear;
end;
end;
procedure TIdDNSServer.TimeToUpdateNodeData(Sender: TObject);
var
Resolver : TIdDNSResolver;
Count : Integer;
begin
Resolver := TIdDNSResolver.Create(Self);
try
Resolver.Host := UDPTunnel.RootDNS_NET.Strings[0];
Resolver.QueryType := [qtAXFR];
Resolver.Resolve((Sender as TIdDNTreeNode).FullName);
for Count := 0 to Resolver.QueryResult.Count-1 do begin
UDPTunnel.UpdateTree(UDPTunnel.Handed_Tree, Resolver.QueryResult.Items[Count]);
end;
finally
FreeAndNil(Resolver);
end;
end;
{ TIdDNS_TCPServer }
procedure TIdDNS_TCPServer.InitComponent;
begin
inherited InitComponent;
FAccessList := TStringList.Create;
end;
destructor TIdDNS_TCPServer.Destroy;
begin
FreeAndNil(FAccessList);
inherited Destroy;
end;
procedure TIdDNS_TCPServer.DoConnect(AContext: TIdContext);
var
Answer, Data, Question: TIdBytes;
QName, QLabel, QResult, PeerIP : string;
LData, QPos, LLength : Integer;
TestHeader : TDNSHeader;
procedure GenerateAXFRData;
begin
TestHeader := TDNSHeader.Create;
try
TestHeader.ParseQuery(Data);
if TestHeader.QDCount > 0 then begin
// parse the question.
QPos := 13;
QLabel := '';
QName := '';
repeat
LLength := Byte(Data[QPos]);
Inc(QPos);
QLabel := BytesToString(Data, QPos, LLength);
Inc(QPos, LLength);
QName := QName + QLabel + '.';
until (QPos >= LData) or (Data[QPos] = 0);
Question := Copy(Data, 13, Length(Data)-12);
QResult := TIdDNSServer(Owner).UDPTunnel.AXFR(TestHeader, QName, Answer);
end;
finally
FreeAndNil(TestHeader);
end;
end;
procedure GenerateAXFRRefuseData;
begin
TestHeader := TDNSHeader.Create;
try
TestHeader.ParseQuery(Data);
TestHeader.Qr := iQr_Answer;
TestHeader.RCode := iRCodeRefused;
Answer := TestHeader.GenerateBinaryHeader;
finally
FreeAndNil(TestHeader);
end;
end;
begin
inherited DoConnect(AContext);
LData := AContext.Connection.IOHandler.ReadInt16;
SetLength(Data, 0);
// RLebeau - why not use ReadBuffer() here?
// Dennies - Sure, in older version, my concern is for real time generate system
// might not generate the data with correct data size we expect.
AContext.Connection.IOHandler.ReadBytes(Data, LData);
{for Count := 1 to LData do begin
AppendByte(Data, AThread.Connection.IOHandler.ReadByte);
end;
}
// PeerIP is ip address.
PeerIP := AContext.Binding.PeerIP;
if AccessControl and (AccessList.IndexOf(PeerIP) = -1) then begin
GenerateAXFRRefuseData;
end else begin
GenerateAXFRData;
end;
if Length(Answer) > 32767 then begin
SetLength(Answer, 32767);
end;
AContext.Connection.IOHandler.Write(Int16(Length(Answer)));
AContext.Connection.IOHandler.Write(Answer);
end;
procedure TIdDNS_TCPServer.SetAccessList(const Value: TStrings);
begin
FAccessList.Assign(Value);
end;
{ TIdDomainExpireCheckThread }
procedure TIdDomainExpireCheckThread.Run;
var
LInterval, LStep: Integer;
begin
LInterval := FInterval;
while LInterval > 0 do begin
LStep := IndyMin(LInterval, 500);
IndySleep(LStep);
Dec(LInterval, LStep);
if Terminated then begin
Exit;
end;
if Assigned(FTimerEvent) then begin
Synchronize(TimerEvent);
end;
end;
end;
procedure TIdDomainExpireCheckThread.TimerEvent;
begin
if Assigned(FTimerEvent) then begin
FTimerEvent(FSender);
end;
end;
{ TIdDomainNameServerMapping }
constructor TIdDomainNameServerMapping.Create(AList : TIdDNSMap);
begin
inherited Create;
CheckScheduler := TIdDomainExpireCheckThread.Create;
CheckScheduler.FInterval := 100000;
CheckScheduler.FSender := Self;
CheckScheduler.FDomain := DomainName;
CheckScheduler.FHost := Host;
CheckScheduler.FTimerEvent := SyncAndUpdate;
FList := List;
FBusy := False;
end;
destructor TIdDomainNameServerMapping.Destroy;
begin
//Self.CheckScheduler.TerminateAndWaitFor;
CheckScheduler.Terminate;
FreeAndNil(CheckScheduler);
inherited Destroy;
end;
procedure TIdDomainNameServerMapping.SetHost(const Value: string);
begin
if (not IsValidIP(Value)) and (not IsValidIPv6(Value)) then begin
raise EIdDNSServerSettingException.Create(RSDNSServerSettingError_MappingHostError);
end;
FHost := Value;
end;
procedure TIdDomainNameServerMapping.SetInterval(const Value: UInt32);
begin
FInterval := Value;
CheckScheduler.FInterval := Value;
end;
procedure TIdDomainNameServerMapping.SyncAndUpdate(Sender: TObject);
//Todo - Dennies Chang should append axfr and update Tree.
var
Resolver : TIdDNSResolver;
RR : TResultRecord;
TNode : TIdDNTreeNode;
Server : TIdDNS_UDPServer;
NeedUpdated, NotThis : Boolean;
Count, TIndex : Integer;
RRName : string;
begin
if FBusy then begin
Exit;
end;
FBusy := True;
try
Resolver := TIdDNSResolver.Create(nil);
try
Resolver.Host := Host;
Resolver.QueryType := [qtAXFR];
Resolver.Resolve(DomainName);
if Resolver.QueryResult.Count = 0 then begin
raise EIdDNSServerSyncException.Create(RSDNSServerAXFRError_QuerySequenceError);
end;
RR := Resolver.QueryResult.Items[0];
if RR.RecType <> qtSOA then begin
raise EIdDNSServerSyncException.Create(RSDNSServerAXFRError_QuerySequenceError);
end;
Server := List.Server;
Interval := TSOARecord(RR).Expire * 1000;
{
//Update MyDomain
if Copy(RR.Name, Length(RR.Name),1) <> '.' then begin
RRName := RR.Name + '.';
end;
}
if Server.Handed_DomainList.IndexOf(RR.Name) = -1 then begin
Server.Handed_DomainList.Add(RR.Name);
end;
TNode := Server.SearchTree(Server.Handed_Tree, RR.Name, TypeCode_SOA);
if TNode = nil then begin
NeedUpdated := True;
end else begin
RRName := RRName;
RRName := Fetch(RRName, '.');
TIndex := TNode.RRs.ItemNames.IndexOf(RR.Name);
NotThis := True;
while (TIndex > -1) and (TIndex <= (TNode.RRs.Count-1)) and
(TNode.RRs.Items[TIndex].RRName = RR.Name) and NotThis do
begin
NotThis := not (TNode.RRs.Items[TIndex] is TIdRR_SOA);
Inc(TIndex);
end;
if not NotThis then begin
Dec(TIndex);
NeedUpdated := (TNode.RRs.Items[TIndex] as TIdRR_SOA).Serial = IntToStr(TSOARecord(RR).Serial);
end else begin
NeedUpdated := True;
end;
end;
if NeedUpdated then begin
if TNode <> nil then begin
Server.Handed_Tree.RemoveChild(Server.Handed_Tree.IndexByNode(TNode));
end;
for Count := 0 to Resolver.QueryResult.Count-1 do begin
RR := Resolver.QueryResult.Items[Count];
Server.UpdateTree(Server.Handed_Tree, RR);
end;
end;
finally
FreeAndNil(Resolver);
end;
finally
FBusy := False;
end;
end;
{ TIdDNSMap }
constructor TIdDNSMap.Create(Server: TIdDNS_UDPServer);
begin
inherited Create;
FServer := Server;
end;
{$IFNDEF USE_OBJECT_ARC}
destructor TIdDNSMap.Destroy;
var
I : Integer;
DNSMP : TIdDomainNameServerMapping;
begin
if Count > 0 then begin
for I := Count-1 downto 0 do begin
DNSMP := Items[I];
FreeAndNil(DNSMP);
Delete(I);
end;
end;
inherited Destroy;
end;
{$ENDIF}
{$IFNDEF HAS_GENERICS_TObjectList}
function TIdDNSMap.GetItem(Index: Integer): TIdDomainNameServerMapping;
begin
Result := TIdDomainNameServerMapping(inherited GetItem(Index));
end;
procedure TIdDNSMap.SetItem(Index: Integer; const Value: TIdDomainNameServerMapping);
begin
inherited SetItem(Index, Value);
end;
{$ENDIF}
procedure TIdDNSMap.SetServer(const Value: TIdDNS_UDPServer);
begin
FServer := Value;
end;
{ TIdDNS_ProcessThread }
constructor TIdDNS_ProcessThread.Create(ACreateSuspended: Boolean;
Data: TIdBytes; MainBinding, Binding: TIdSocketHandle;
Server: TIdDNS_UDPServer);
begin
inherited Create(ACreateSuspended);
FMyData := nil;
FData := Data;
FMyBinding := Binding;
FMainBinding := MainBinding;
FServer := Server;
FreeOnTerminate := True;
end;
procedure TIdDNS_ProcessThread.ComposeErrorResult(var VFinal: TIdBytes;
OriginalHeader: TDNSHeader; OriginalQuestion : TIdBytes;
ErrorStatus: Integer);
begin
case ErrorStatus of
iRCodeQueryNotImplement :
begin
OriginalHeader.Qr := iQr_Answer;
OriginalHeader.RCode := iRCodeNotImplemented;
VFinal := OriginalHeader.GenerateBinaryHeader;
AppendBytes(VFinal, OriginalQuestion, 12);
end;
iRCodeQueryNotFound :
begin
OriginalHeader.Qr := iQr_Answer;
OriginalHeader.RCode := iRCodeNameError;
OriginalHeader.ANCount := 0;
VFinal := OriginalHeader.GenerateBinaryHeader;
//VFinal := VFinal;
end;
end;
end;
destructor TIdDNS_ProcessThread.Destroy;
begin
FServer := nil;
FMainBinding := nil;
FMyBinding.CloseSocket;
FreeAndNil(FMyBinding);
FreeAndNil(FMyData);
inherited Destroy;
end;
procedure TIdDNS_ProcessThread.QueryDomain;
var
QName, QLabel, RString : string;
Temp, ExternalQuery, Answer, FinalResult : TIdBytes;
DNSHeader_Processing : TDNSHeader;
QType, QClass : UInt16;
QPos, QLength, LLength : Integer;
ABinding: TIdSocketHandle;
begin
ExternalQuery := FData;
ABinding := MyBinding;
Temp := Copy(FData, 0, Length(FData));
SetLength(FinalResult, 0);
QType := TypeCode_A;
if Length(FData) >= 12 then begin
DNSHeader_Processing := TDNSHeader.Create;
try
// RLebeau: this does not make sense to me. ParseQuery() always returns
// 0 when the data length is >= 12 unless an exception is raised, which
// should only happen if the GStack object is invalid...
//
if DNSHeader_Processing.ParseQuery(ExternalQuery) <> 0 then begin
FServer.DoAfterQuery(ABinding, DNSHeader_Processing, Temp, RString, ExternalQuery);
AppendBytes(FinalResult, Temp);
end else begin
if DNSHeader_Processing.QDCount > 0 then begin
QPos := 12; //13; Modified in Dec. 13, 2004 by Dennies
QLength := Length(ExternalQuery);
if QLength > 12 then begin
QName := '';
repeat
SetLength(Answer, 0);
LLength := ExternalQuery[QPos];
Inc(QPos);
QLabel := BytesToString(ExternalQuery, QPos, LLength);
Inc(QPos, LLength);
QName := QName + QLabel + '.';
until (QPos >= QLength) or (ExternalQuery[QPos] = 0);
Inc(QPos);
QType := GStack.NetworkToHost(TwoByteToUInt16(ExternalQuery[QPos], ExternalQuery[QPos + 1]));
Inc(QPos, 2);
QClass := GStack.NetworkToHost(TwoByteToUInt16(ExternalQuery[QPos], ExternalQuery[QPos + 1]));
FServer.DoBeforeQuery(ABinding, DNSHeader_Processing, Temp);
RString := CompleteQuery(DNSHeader_Processing, QName, ExternalQuery, Answer, QType, QClass, nil);
if RString = cRCodeQueryNotImplement then begin
ComposeErrorResult(FinalResult, DNSHeader_Processing, ExternalQuery, iRCodeQueryNotImplement);
end
else if (RString = cRCodeQueryReturned) then begin
FinalResult := Answer;
end
else if (RString = cRCodeQueryNotFound) or (RString = cRCodeQueryCacheFindError) then begin
ComposeErrorResult(FinalResult, DNSHeader_Processing, ExternalQuery, iRCodeQueryNotFound);
end
else begin
FinalResult := CombineAnswer(DNSHeader_Processing, ExternalQuery, Answer);
end;
FServer.DoAfterQuery(ABinding, DNSHeader_Processing, FinalResult, RString, Temp);
//AppendString(FinalResult, Temp);
end;
end;
end;
finally
try
FData := FinalResult;
FServer.DoAfterSendBack(ABinding, DNSHeader_Processing, FinalResult, RString, ExternalQuery);
if (FServer.CacheUnknowZone) and
(RString <> cRCodeQueryCacheFindError) and
(RString <> cRCodeQueryCacheOK) and
(RString <> cRCodeQueryOK) and
(RString <> cRCodeQueryNotImplement) then
begin
FServer.SaveToCache(FinalResult, QName, QType);
FServer.DoAfterCacheSaved(Self.FServer.FCached_Tree);
end;
finally
FreeAndNil(DNSHeader_Processing);
end;
end;
end;
end;
procedure TIdDNS_ProcessThread.Run;
begin
try
QueryDomain;
SendData;
finally
Stop;
Terminate;
end;
end;
procedure TIdDNS_ProcessThread.SetMyBinding(const Value: TIdSocketHandle);
begin
FMyBinding := Value;
end;
procedure TIdDNS_ProcessThread.SetMyData(const Value: TStream);
begin
FMyData := Value;
end;
procedure TIdDNS_ProcessThread.SetServer(const Value: TIdDNS_UDPServer);
begin
FServer := Value;
end;
function TIdDNS_ProcessThread.CombineAnswer(Header: TDNSHeader; const EQuery, Answer: TIdBytes): TIdBytes;
begin
Result := Header.GenerateBinaryHeader;
AppendBytes(Result, EQuery, 12);
AppendBytes(Result, Answer);
end;
procedure TIdDNS_ProcessThread.ExternalSearch(ADNSResolver: TIdDNSResolver; Header: TDNSHeader;
Question: TIdBytes; var Answer: TIdBytes);
var
Server_Index : Integer;
MyDNSResolver : TIdDNSResolver;
begin
Server_Index := 0;
if ADNSResolver = nil then begin
MyDNSResolver := TIdDNSResolver.Create;
MyDNSResolver.WaitingTime := 2000;
end else
begin
MyDNSResolver := ADNSResolver;
end;
try
repeat
MyDNSResolver.Host := FServer.RootDNS_NET.Strings[Server_Index];
try
MyDNSResolver.InternalQuery := Question;
MyDNSResolver.Resolve('');
Answer := MyDNSResolver.PlainTextResult;
except
// Todo: Create DNS server interal resolver error.
on EIdDnsResolverError do
begin
//Empty Event, for user to custom the event handle.
end;
on EIdSocketError do
begin
end;
else
begin
end;
end;
Inc(Server_Index);
until (Server_Index >= FServer.RootDNS_NET.Count) or (Length(Answer) > 0);
finally
if ADNSResolver = nil then begin
FreeAndNil(MyDNSResolver);
end;
end;
end;
procedure TIdDNS_ProcessThread.InternalSearch(Header: TDNSHeader; QName: string; QType: UInt16;
var Answer: TIdBytes; IfMainQuestion: boolean; IsSearchCache: Boolean = False;
IsAdditional: boolean = false; IsWildCard : boolean = false;
WildCardOrgName: string = '');
begin
end;
procedure TIdDNS_ProcessThread.SaveToCache(ResourceRecord: TIdBytes; QueryName: string; OriginalQType: UInt16);
var
TempResolver : TIdDNSResolver;
Count : Integer;
TNode : TIdDNTreeNode;
RR_Err : TIdRR_Error;
begin
TempResolver := TIdDNSResolver.Create(nil);
try
// RLebeau: FillResultWithOutCheckId() is deprecated, but not using FillResult()
// here yet because it validates the DNSHeader.RCode, and I do not know if that
// is needed here. I don't want to break this logic...
TempResolver.FillResultWithOutCheckId(ResourceRecord);
if TempResolver.DNSHeader.ANCount > 0 then begin
for Count := 0 to TempResolver.QueryResult.Count-1 do begin
FServer.UpdateTree(FServer.Cached_Tree, TempResolver.QueryResult.Items[Count]);
end; // for loop
end else begin
TNode := Self.SearchTree(FServer.Cached_Tree, QueryName, TypeCode_Error);
if TNode = nil then begin
RR_Err := TIdRR_Error.Create;
RR_Err.RRName := QueryName;
RR_Err.TTL := 600;
FServer.UpdateTree(FServer.Cached_Tree, RR_Err);
end;
end;
finally
FreeAndNil(TempResolver);
end;
end;
function TIdDNS_ProcessThread.SearchTree(Root: TIdDNTreeNode; QName: String; QType: UInt16): TIdDNTreeNode;
var
RRIndex : integer;
NodeCursor : TIdDNTreeNode;
NameLabels : TStrings;
OneNode, FullName : string;
Found : Boolean;
begin
Result := nil;
NameLabels := TStringList.Create;
try
FullName := QName;
NodeCursor := Root;
Found := False;
repeat
OneNode := Fetch(FullName, '.');
if OneNode <> '' then begin
NameLabels.Add(OneNode);
end;
until FullName = '';
repeat
IndySleep(0);
if QType <> TypeCode_SOA then begin
RRIndex := NodeCursor.ChildIndex.IndexOf(NameLabels.Strings[NameLabels.Count - 1]);
if RRIndex <> -1 then begin
NameLabels.Delete(NameLabels.Count - 1);
NodeCursor := NodeCursor.Children[RRIndex];
if NameLabels.Count = 1 then begin
Found := NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1;
end else begin
Found := NameLabels.Count = 0;
end;
end
else if NameLabels.Count = 1 then begin
Found := NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1;
if not Found then begin
NameLabels.Clear;
end;
end
else begin
NameLabels.Clear;
end;
end else begin
RRIndex := NodeCursor.ChildIndex.IndexOf(NameLabels.Strings[NameLabels.Count - 1]);
if RRIndex <> -1 then begin
NameLabels.Delete(NameLabels.Count - 1);
NodeCursor := NodeCursor.Children[RRIndex];
if NameLabels.Count = 1 then begin
Found := NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1;
end else begin
Found := NameLabels.Count = 0;
end;
end
else if NameLabels.Count = 1 then begin
Found := (NodeCursor.RRs.ItemNames.IndexOf(NameLabels.Strings[0]) <> -1);
if not Found then begin
NameLabels.Clear;
end;
end
else begin
NameLabels.Clear;
end;
end;
until (NameLabels.Count = 0) or Found;
if Found then begin
Result := NodeCursor;
end;
finally
FreeAndNil(NameLabels);
end;
end;
function TIdDNS_ProcessThread.CompleteQuery(DNSHeader: TDNSHeader;
Question: string; OriginalQuestion: TIdBytes; var Answer : TIdBytes;
QType, QClass : UInt16; DNSResolver : TIdDNSResolver) : string;
var
IsMyDomains : boolean;
LAnswer, TempAnswer, RRData: TIdBytes;
WildQuestion, TempDomain : string;
LIdx: Integer;
begin
// QClass = 1 => IN, we support only "IN" class now.
// QClass = 2 => CS,
// QClass = 3 => CH, we suppor "CHAOS" class now, but only "version.bind." info.
// from 2004/6/28
// QClass = 4 => HS.
RRData := nil;
TempAnswer := nil;
TempDomain := LowerCase(Question);
case QClass of
Class_IN :
begin
IsMyDomains := FServer.Handed_DomainList.IndexOf(TempDomain) > -1;
if not IsMyDomains then begin
Fetch(TempDomain, '.');
IsMyDomains := FServer.Handed_DomainList.IndexOf(TempDomain) > -1;
end;
if IsMyDomains then begin
FServer.InternalSearch(DNSHeader, Question, QType, LAnswer, True, False, False);
Answer := LAnswer;
if (QType in [TypeCode_A, TypeCode_AAAA]) and (Length(Answer) = 0) then begin
FServer.InternalSearch(DNSHeader, Question, TypeCode_CNAME, LAnswer, True, False, True);
if Length(LAnswer) > 0 then begin
AppendBytes(Answer, LAnswer);
end;
end;
WildQuestion := Question;
Fetch(WildQuestion, '.');
WildQuestion := '*.' + WildQuestion;
FServer.InternalSearch(DNSHeader, WildQuestion, QType, LAnswer, True, False, False, True, Question);
{
FServer.InternalSearch(DNSHeader, Question, QType, LAnswer, True, True, False);
}
if Length(LAnswer) > 0 then begin
AppendBytes(Answer, LAnswer);
end;
if Length(Answer) > 0 then begin
Result := cRCodeQueryOK;
end else begin
Result := cRCodeQueryNotFound;
end;
end else begin
FServer.InternalSearch(DNSHeader, Question, QType, Answer, True, True, False);
if (QType in [TypeCode_A, TypeCode_AAAA]) and (Length(Answer) = 0) then begin
FServer.InternalSearch(DNSHeader, Question, TypeCode_CNAME, LAnswer, True, True, False);
if Length(LAnswer) > 0 then begin
AppendBytes(Answer, LAnswer);
end;
end;
if Length(Answer) > 0 then begin
Result := cRCodeQueryCacheOK;
end else begin
//QType := TypeCode_Error;
FServer.InternalSearch(DNSHeader, Question, QType, Answer, True, True, False);
if BytesToString(Answer) = 'Error' then begin {do not localize}
Result := cRCodeQueryCacheFindError;
end else begin
FServer.ExternalSearch(DNSResolver, DNSHeader, OriginalQuestion, Answer);
if Length(Answer) > 0 then begin
Result := cRCodeQueryReturned;
end else begin
Result := cRCodeQueryNotImplement;
end;
end;
end;
end;
end;
Class_CHAOS :
begin
if TempDomain = 'version.bind.' then begin {do not localize}
if FServer.offerDNSVersion then begin
TempAnswer := DomainNameToDNSStr('version.bind.'); {do not localize}
RRData := NormalStrToDNSStr(FServer.DNSVersion);
SetLength(LAnswer, Length(TempAnswer) + (SizeOf(UInt16)*3) + SizeOf(UInt32) + Length(RRData));
CopyTIdBytes(TempAnswer, 0, LAnswer, 0, Length(TempAnswer));
LIdx := Length(TempAnswer);
CopyTIdUInt16(GStack.HostToNetwork(UInt16(TypeCode_TXT)), LAnswer, LIdx);
Inc(LIdx, SizeOf(UInt16));
CopyTIdUInt16(GStack.HostToNetwork(UInt16(Class_CHAOS)), LAnswer, LIdx);
Inc(LIdx, SizeOf(UInt16));
CopyTIdUInt32(GStack.HostToNetwork(UInt32(86400)), LAnswer, LIdx); {do not localize}
Inc(LIdx, SizeOf(UInt32));
CopyTIdUInt16(GStack.HostToNetwork(UInt16(Length(RRData))), LAnswer, LIdx);
Inc(LIdx, SizeOf(UInt16));
CopyTIdBytes(RRData, 0, LAnswer, LIdx, Length(RRData));
Answer := LAnswer;
DNSHeader.ANCount := 1;
DNSHeader.AA := 1;
Result := cRCodeQueryOK;
end else begin
Result := cRCodeQueryNotImplement;
end;
end else begin
Result := cRCodeQueryNotImplement;
end;
end;
else
begin
Result := cRCodeQueryNotImplement;
end;
end;
end;
procedure TIdDNS_ProcessThread.SendData;
begin
FServer.GlobalCS.Enter;
try
FMainBinding.SendTo(FMyBinding.PeerIP, FMyBinding.PeerPort, FData, FMyBinding.IPVersion);
finally
FServer.GlobalCS.Leave;
end;
end;
procedure TIdDNS_UDPServer.DoAfterCacheSaved(CacheRoot: TIdDNTreeNode);
begin
if Assigned(FOnAfterCacheSaved) then begin
FOnAfterCacheSaved(CacheRoot);
end;
end;
procedure TIdDNS_UDPServer.DoUDPRead(AThread: TIdUDPListenerThread;
const AData: TIdBytes; ABinding: TIdSocketHandle);
var
PThread : TIdDNS_ProcessThread;
BBinding : TIdSocketHandle;
Binded : Boolean;
begin
inherited DoUDPRead(AThread, AData, ABinding);
Binded := False;
BBinding := TIdSocketHandle.Create(nil);
try
BBinding.SetPeer(ABinding.PeerIP, ABinding.PeerPort, ABinding.IPVersion);
BBinding.IP := ABinding.IP;
repeat
try
BBinding.Port := 53;
BBinding.AllocateSocket(Id_SOCK_DGRAM);
Binded := True;
except
end;
until Binded;
PThread := TIdDNS_ProcessThread.Create(True, AData, ABinding, BBinding, Self);
except
FreeAndNil(BBinding);
raise;
end;
PThread.Start;
end;
end.
Reference in New Issue View Git Blame Copy Permalink