iddnsresolver.pas

Indy控件的使用源代码

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10135: IdDNSResolver.pas 
{
{   Rev 1.5    4/30/2003 03:06:56 AM  JPMugaas
}
{
{   Rev 1.2    1/3/2003 1:53:52 PM  VVassiliev
}
{
{   Rev 1.1    01/02/2003 9:42:18 AM  VVassiliev
{ Bug fix 659874, 660267
}
{
{   Rev 1.0    2002.11.12 10:36:22 PM  czhower
}
{
  IdDNSResolver.

  Started: sometime.
  Finished:

  The Resolver does NOT support COMPLETE XFER's since these should be based   
  on the TCP protocol. Use the appropriate component for that (if one exists!).

  The resolver also does not support Chaos RR. Only IN RR are supported as of this time.
  Part of code from Ray Malone
}

// SG 28/1/02: Changed the DNSStrToDomain function according to original Author of the old comp: Ray Malone
{SG 10/07/01 Added support for qrStar query}
{VV 12/09/01 Added construction of reverse query (PTR)}
{DS 12/31/01 Corrected ReponsiblePerson spelling }
{VV 01/02/03 TQueryResult.DNSStrToDomain fix}

{ TODO : Add structure of IDHEADER IN FIGURE }

unit IdDNSResolver;

interface

uses
  Classes,
  IdGlobal,
  IdUDPClient;

type
  { TODO : Solve problem with obsolete records }
  TQueryRecordTypes = (qtA, qtNS, qtMD, qtMF, qtName, qtSOA, qtMB,
    qtMG, qtMR, qtNull, qtWKS, qtPTR, qtHINFO, qtMINFO, qtMX, qtTXT, qtSTAR);
const
  // Lookup table for query record values.
  QueryRecordValues: array [0..16] of word= (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,255);
  QueryRecordTypes: Array [0..16] of TQueryRecordTypes = (qtA, qtNS, qtMD, qtMF, qtName, qtSOA, qtMB,
    qtMG, qtMR, qtNull, qtWKS, qtPTR, qtHINFO, qtMINFO, qtMX, qtTXT, qtSTAR);
type
  TQueryType = set of TQueryRecordTypes;

  TResultRecord = class(TCollectionItem) // Rename to REsourceRecord
  private
    FRecType: TQueryRecordTypes;
    FRecClass: word;
    FName: string;
    FTTL: cardinal;
    FRData: String;
    FRDataLength: Integer;
  public
    // Parse the data (descendants only)
    procedure Parse(CompleteMessage: String; APos: Integer); virtual;
    { TODO : This needs to change }
    property RecType: TQueryRecordTypes read FRecType;
    property RecClass: word read FRecClass;
    property Name: string read FName;
    property TTL: cardinal read FTTL;
    Property RDataLength: Integer read FRDataLength;
    property RData: String read FRData;
    destructor Destroy; override;
  end;

  TRDATARecord = class(TResultRecord)
  private
    FIPAddress: String;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property IPAddress: string read FIPAddress;
  end;

  TARecord = class(TRDATARecord)
  end;

  TWKSRecord = Class(TResultRecord)
  private
    FByteCount: integer;
    FAddress: String;
    FProtocol: Word;
    FData: PByte;
    function GetABit(index: integer): Byte;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    property Address: String read FAddress;
    property Protocol: Word read FProtocol;
    property BitMap[index: integer]: Byte read GetABit;
    property ByteCount: integer read FByteCount;
  end;

  TMXRecord = class(TResultRecord)
  private
    FExchangeServer: string;
    FPreference: Word;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;

    property ExchangeServer: string read FExchangeServer;
    property Preference: word read FPreference;
  end;

  TTextRecord = class(TResultRecord)
  private
    FText: TStrings;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    Property Text: TStrings read FText;
  end;

  THINFORecord = Class(TTextRecord)
  private
    FCPU: String;
    FOS: String;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    property CPU: String read FCPU;
    property OS: String read FOS;
  end;

  TMINFORecord = Class(TResultRecord)
  private
    FResponsiblePerson: String;
    FErrorMailbox: String;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    property ResponsiblePersonMailbox: String read FResponsiblePerson;
    property ErrorMailbox: String read FErrorMailbox;
  end;

  TSOARecord = class(TResultRecord)
  private
    FSerial: cardinal;
    FMinimumTTL: Cardinal;
    FRefresh: Cardinal;
    FRetry: Cardinal;
    FMNAME: string;
    FRNAME: string;
    FExpire: Cardinal;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;

    property Primary: string read FMNAME;
    property ResponsiblePerson: string read FRNAME;
    property Serial: cardinal read FSerial;
    property Refresh: Cardinal read FRefresh;
    property Retry: Cardinal read FRetry;
    property Expire: Cardinal read FExpire;

    property MinimumTTL: Cardinal read FMinimumTTL;
  end;

  TNAMERecord = class(TResultRecord)
  private
    FHostName: string;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property HostName: string read FHostName;
  end;

  TNSRecord = class(TNAMERecord)
  end;

  TCNRecord = class(TNAMERecord)
  end;


  TQueryResult = class(TCollection)
  private
    FRec: TResultRecord;
    FDomainName: String;
    FQueryClass: Word;
    FQueryType: Word;
    FQueryPointerList: TStringList;
    function DNSStrToDomain(SrcStr: string; var Idx: Integer): string;
    function NextDNSLabel(DNSStr: string; Var APos: Integer): string;
    procedure SetItem(Index: Integer; Value: TResultRecord);
    function GetItem(Index: Integer): TResultRecord;
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AResultRecord: TResultRecord);
    destructor destroy; override;
    function Add(Answer: string; var APos: Integer): TResultRecord;
    procedure Clear; reintroduce;

    Property QueryClass: Word read FQueryClass;
    Property QueryType: Word read FQueryType;
    Property DomainName: String read FDomainName;

    property Items[Index: Integer]: TResultRecord read GetItem write SetItem; default;
  end;



  TPTRRecord = Class(TNAMERecord)
  end;

  // This class is used INTERNALLY. It does not need to be accessed by the user
  TDNSHeader = class
  private
    FID: Word;
    FBitCode: Word;
    FQDCount: Word;
    FANCount: Word;
    FNSCount: Word;
    FARCount: Word;
    function GetAA: Word;
    function GetOpCode: Word;
    function GetQr: Word;
    function GetRA: Word;
    function GetRCode: Word;
    function GetRD: Word;
    function GetTC: Word;
    procedure SetAA(const Value: Word);
    procedure SetOpCode(const Value: Word);
    procedure SetQr(const Value: Word);
    procedure SetRA(const Value: Word);
    procedure SetRCode(const Value: Word);
    procedure SetRD(const Value: Word);
    procedure SetTC(const Value: Word);

  public
    constructor Create;
    procedure ClearByteCode;

    property ID: Word read FID write FID;

    property Qr: Word read GetQr write SetQr;
    property OpCode: Word read GetOpCode write SetOpCode;
    property AA: Word read GetAA write SetAA;
    property TC: Word read GetTC write SetTC;
    property RD: Word read GetRD write SetRD;
    property RA: Word read GetRA write SetRA;
    property RCode: Word read GetRCode write SetRCode;
    property BitCode: Word read FBitCode;
    property QDCount: Word read FQDCount write FQDCount;
    property ANCount: Word read FANCount write FANCount;
    property NSCount: Word read FNSCount write FNSCount;
    property ARCount: Word read FARCount write FARCount;
  end;

  TIdDNSResolver = class(TIdUDPClient)
  private
    FDNSHeader: TDNSHeader;
    FQueryResult: TQueryResult;
    FInternalQuery: string;
    FQuestionLength: Integer;
    FAllowRecursiveQueries: Boolean;
    procedure SetAllowRecursiveQueries(const Value: Boolean);
  protected
    FQueryRecords: TQueryType; // Compression dictionary


    procedure ParseAnswers(Answer: String; AnswerNum: Cardinal);
    procedure CreateQuery(ADomain: string);
    procedure FillResult(AResult: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Resolve(ADomain: string);
    property QueryResult: TQueryResult read FQueryResult;
  published
    property QueryRecords: TQueryType read FQueryRecords write FQueryRecords;
    property AllowRecursiveQueries: Boolean read FAllowRecursiveQueries write SetAllowRecursiveQueries default true;
  end;

implementation

uses
  IdAssignedNumbers,
  IdBaseComponent,
  IdResourceStrings,
  IdException,
  SysUtils;

const
  cRCodeNoError   = 0;
  cRCodeFormatErr = 1;
  cRCodeServerErr = 2;
  cRCodeNameErr   = 3;
  cRCodeNotImplemented = 4;
  cRCodeRefused  = 5;

  cRCodeStrs : Array[cRCodeNoError..cRCodeRefused] Of String =
    (RSCodeNoError,
    RSCodeQueryFormat,
    RSCodeQueryServer,
    RSCodeQueryName,
    RSCodeQueryNotImplemented,
    RSCodeQueryQueryRefused);

{ TODO : Move to IdGlobal }
function WordToTwoCharStr(AWord : Word): String;
begin
  Result := Chr ( Hi ( AWord ) ) + Chr ( Lo ( AWord ) );
end;

function FourCharToCardinal(AChar1,AChar2,AChar3,AChar4 : Char): Cardinal;
var
  LCardinal: TIdCardinalBytes;
begin
  LCardinal.Byte1 := Ord(AChar4);
  LCardinal.Byte2 := Ord(AChar3);
  LCardinal.Byte3 := Ord(AChar2);
  LCardinal.Byte4 := Ord(AChar1);
  Result := LCardinal.Whole;
end;

{ TODO : Move to IdGlobal }
function TwoCharToWord(AChar1,AChar2: Char):Word;
//Since Replys are returned as Strings, we need a rountime to convert two
// characters which are a 2 byte U Int into a two byte unsigned integer
begin
  Result := Word((Ord(AChar1) shl 8) and $FF00) or Word(Ord(AChar2) and $00FF);
end;

{ TODO : Move these to member }
function GetErrorStr(Code, Id :Integer): String;
begin
  case code Of
    1 : Result := Format ( RSQueryInvalidQueryCount, [ Id ] );
    2 : Result := Format ( RSQueryInvalidPacketSize, [ Id ] );
    3 : Result := Format ( RSQueryLessThanFour, [ Id ] );
    4 : Result := Format ( RSQueryInvalidHeaderID, [ Id ] );
    5 : Result := Format ( RSQueryLessThanTwelve, [ Id ] );
    6 : Result := Format ( RSQueryPackReceivedTooSmall, [Id] );
  end;  //case code Of
end;

// SG 28/1/02: Changed that function according to original Author of the old comp: Ray Malone
function TQueryResult.DNSStrToDomain(SrcStr: string; var Idx: Integer): string;
var
  LabelStr : String;
  Len : Integer;
  SavedIdx : Integer;
  AChar :Char;
  fRPackSize: Integer;
begin
    Result := '';                {Do not Localize}
    fRPackSize := Length(SrcStr);
    SavedIdx := 0;
    repeat
      Len := byte(SrcStr[Idx]);
      while (Len and $C0) = $C0 do // {!!0.01} added loop for pointer
      begin                         // that points to a pointer. Removed  >63 hack. Am I really that stupid?
        if SavedIdx = 0 then SavedIdx := Succ(Idx); // it is important to return to original index  spot
	// when we go down more than 1 level.
        aChar := char(Len and $3F);                       // strip first two bits ($C) from first byte of offset pos
        Idx := TwoCharToWord(aChar, SrcStr[Idx + 1]) + 1; // add one to index for delphi string index
        Len := byte(SrcStr[Idx]);  // if len is another $Cx we will (while) loop again
      end;
      Assert(Idx < fRPackSize, GetErrorStr(2, 2)); // loop screwed up. This  very very unlikely now  could be removed.
      SetLength(LabelStr, Len);
      if Len > 0 then
      begin
        Move(SrcStr[Idx + 1], LabelStr[1], Length(LabelStr));
        Inc(Idx, Length(LabelStr) + 1);
      end;
      if Pred(Idx) > fRPackSize then // len byte was corrupted puting us past end of packet
        raise  EIdDnsResolverError.Create(GetErrorStr(2, 3));
      Result := Result + LabelStr + '.';  // concat and add period.  {Do not Localize}
    until (SrcStr[Idx] = char(0)) or (Idx >= Length(SrcStr)); // name field ends with nul byte
    if Result[Length(Result)] = '.' then  // remove final period    {Do not Localize}
    begin
      System.Delete(Result, Length(Result), 1);
    end;
    if SavedIdx > 0 then Idx := SavedIdx; // restore original Idx +1
    Inc(Idx); // set to first char of next item in  the resource
end;

function TQueryResult.NextDNSLabel(DNSStr: string; Var APos: Integer): string;
var
  LabelLength: Byte;
  function IsPointer(TestVal: Integer): boolean;
  begin
    result := (TestVal AND $C0) <> 0;
  end;
begin
  result := '';      {Do not Localize}
  if Length(DNSStr) > APos then
  begin
    LabelLength := Integer(DNSStr[APos]);
    if IsPointer(LabelLength) then
    begin
      // do not dereference pointers
      result := '';    {Do not Localize}
      Inc(APos, 2);
    end
    else
    begin
      if (LabelLength > 0) then
      begin
        result := Copy(DNSStr, APos + 1, LabelLength);
        inc(APos, LabelLength + 1);
      end
      else
      begin
        result := '';      {Do not Localize}
        Inc(APos);
      end;
    end;
  end;
end;




{ TODO : Move these to member }
function GetRCodeStr(RCode : Integer): String;
begin
  if Rcode in [cRCodeNoError..cRCodeRefused] then
  begin
    Result :=  cRCodeStrs[Rcode];
  end  // if Rcode in [cRCodeNoError..cRCodeRefused] then
  else
  begin
    Result := RSCodeQueryUnknownError;
  end; //else.. if Rcode in [cRCodeNoError..cRCodeRefused] then
end;

{ TIdDNSResolver }

constructor TIdDNSResolver.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Port := IdPORT_DOMAIN;
  FQueryResult := TQueryResult.Create(nil);
  FDNSHeader := TDNSHeader.Create;
  FAllowRecursiveQueries := true;
end;

procedure TIdDNSResolver.CreateQuery(ADomain: string);


  function DoDomainName(ADNS : String): string;
  var
    BufStr : String;
    aPos : Integer;
  begin                         { DoDomainName }
    Result := '';
    while Length(aDns) > 0 do
    begin
      aPos := Pos('.', aDns);    {Do not Localize}
      if aPos = 0 then
      begin
        aPos := Length(aDns) + 1;
      end; //if aPos = 0 then
      BufStr := Copy(aDns, 1, aPos - 1);
      Delete(aDns, 1, aPos);
      Result := Result + Chr(Length(BufStr)) + BufStr;
    end;
  end;

  function DoHostAddress(aDNS :String): string;
  var
    BufStr,
    BufStr2 : String;
    aPos : Integer;
  begin                         { DoHostAddress }
    while Length( aDns ) > 0 do
    begin
      aPos := IndyPos( '.', aDns );   {Do not Localize}
      if aPos =0 then
      begin
        aPos := Length(aDns) + 1;
      end;  //if aPos =0 then
      BufStr := Copy(aDns, 1, aPos-1 );
      Delete ( aDns, 1, aPos);
      BufStr2 := Chr ( Length ( BufStr ) ) + BufStr + BufStr2;
    end;  // while Length( aDns ) > 0 do
    Result := BufStr2 + Chr ( 07 ) + 'in-addr' + Chr ( 04 ) + 'arpa'; {do not localize}
  end;                          { DoHostAddress }


var
  ARecType: TQueryRecordTypes;
  iQ: Integer;
  AQuestion: string;
begin
  AQuestion := '';
  FDNSHeader.ClearByteCode;
  FDNSHeader.Qr := 0;
  FDNSHeader.OpCode := 0;
  FDNSHeader.RD := Word(FAllowRecursiveQueries);
  iQ := 0;
  // Iterate thru questions
  FInternalQuery := WordToTwoCharStr(FDNSHeader.ID);
  FInternalQuery := FInternalQuery + WordToTwoCharStr(FDNSHeader.BitCode);
  { TODO : Optimize for non-double loop }
  for ARecType := Low(TQueryRecordTypes) to High(TQueryRecordTypes) do begin
    if ARecType in QueryRecords then begin
      inc(iQ);
    end;