rtcdnsquery.pas

Delphi快速开发Web Server

{
  "DNS Query component" - Copyright (c) Danijel Tkalcec
  @html(<br>)

  Based on: [
    TDnsQuery from ICS by Fran鏾is PIETTE
    francois.piette(at)overbyte.be  http://www.overbyte.be
    francois.piette(at)rtfm.be      http://www.rtfm.be/fpiette
    francois.piette(at)pophost.eunet.be
    Copyright (C) 1996-2004 by Fran鏾is PIETTE
    Rue de Grady 24, 4053 Embourg, Belgium. Fax: [phone]
    <francois.piette(at)overbyte.be> ]

  @exclude
}
unit rtcDnsQuery;

{$INCLUDE rtcDefs.inc}

{$B-}           { Enable partial boolean evaluation   }
{$T-}           { Untyped pointers                    }
{$R-}           { Disable range checking              }
{$IFNDEF VER80} { Not for Delphi 1                    }
    {$J+}       { Allow typed constant to be modified }
{$ENDIF}
{$IFDEF VER110} { C++ Builder V3.0                    }
    {$ObjExportAll On}
{$ENDIF}

interface

uses
  Windows, Messages, SysUtils, Classes,
  Graphics, Controls, Forms, Dialogs,

  rtcConn, rtcUdpCli, WSocket_rtc;

const
  DnsQueryVersion    = 001;

  { Maximum answers (responses) count }
  MAX_ANCOUNT     = 50;
  { Maximum number of MX records taken into account in responses }
  MAX_MX_RECORDS  = 50;
  MAX_A_RECORDS   = 50;

  { DNS Classes }
  DnsClassIN      = 1;   // The internet
  DnsClassCS      = 2;   // The CSNET class (obsolete, used only for examples)
  DnsClassCH      = 3;   // The CHAOS class
  DnsClassHS      = 4;   // Hesiod name service
  DnsClassALL     = 255; // Any class

  { Type of query/response a DNS can handle }
  DnsQueryA       = 1;  // A     HostAddress
  DnsQueryNS      = 2;  // NS    Authoritative name server
  DnsQueryMD      = 3;  // MD    MailDestination, obsolete, use Mail Exchange
  DnsQueryMF      = 4;  // MF    MailForwarder, obsolete, use Mail Exchange
  DnsQueryCNAME   = 5;  // CNAME CanonicalName
  DnsQuerySOA     = 6;  // SOA   Start of a Zone of Authority
  DnsQueryMB      = 7;  // MB    MailBox, experimental
  DnsQueryMG      = 8;  // MG    MailGroup, experimental
  DnsQueryMR      = 9;  // MR    MailRename, experimental
  DnsQueryNULL    = 10; // NULL  Experimental
  DnsQueryWKS     = 11; // WKS   Well Known Service Description
  DnsQueryPTR     = 12; // PTR   Domain Name Pointer
  DnsQueryHINFO   = 13; // HINFO Host Information
  DnsQueryMINFO   = 14; // MINFO Mailbox information
  DnsQueryMX      = 15; // MX    Mail Exchange
  DnsQueryTXT     = 16; // TXT   Text Strings

  { Some additional type only allowed in queries }
  DnsQueryAXFR    = 252; // Transfer for an entire zone
  DnsQueryMAILB   = 253; // Mailbox related records (MB, MG or MR)
  DnsQueryMAILA   = 254; // MailAgent, obsolete, use MX instead
  DnsQueryALL     = 255; // Request ALL records

  { Opcode field in query flags }
  DnsOpCodeQUERY  = 0;
  DnsOpCodeIQUERY = 1;
  DnsOpCodeSTATUS = 2;

type
  TDnsAnswerNameArray   = packed array [0..MAX_ANCOUNT - 1]    of String;
  TDnsAnswerTypeArray   = packed array [0..MAX_ANCOUNT - 1]    of Integer;
  TDnsAnswerClassArray  = packed array [0..MAX_ANCOUNT - 1]    of Integer;
  TDnsAnswerTTLArray    = packed array [0..MAX_ANCOUNT - 1]    of LongInt;
  TDnsAnswerTagArray    = packed array [0..MAX_ANCOUNT - 1]    of Integer;
  TDnsMXPreferenceArray = packed array [0..MAX_MX_RECORDS - 1] of Integer;
  TDnsMXExchangeArray   = packed array [0..MAX_MX_RECORDS - 1] of String;
  TDnsAddressArray      = packed array [0..MAX_A_RECORDS - 1]  of TInAddr;

  TDnsRequestDoneEvent = procedure (Sender : TObject; Error : WORD) of Object;
  TDnsRequestHeader = packed record
      ID      : WORD;
      Flags   : WORD;
      QDCount : WORD;
      ANCount : WORD;
      NSCount : WORD;
      ARCount : WORD;
  end;
  PDnsRequestHeader = ^TDnsRequestHeader;

  TRtcDnsQuery = class(TComponent)
  private
    { D閏larations priv閑s }
  protected
    FWSocket                    : TRtcUdpClient;
    FPort                       : String;
    FAddr                       : String;
    FIDCount                    : WORD;
    FQueryBuf                   : array [0..511] of char;
    FQueryLen                   : Integer;
    FResponseBuf                : array [0..511] of char;
    FResponseLen                : Integer;
    FResponseID                 : Integer;
    FResponseCode               : Integer;
    FResponseOpCode             : Integer;
    FResponseAuthoritative      : Boolean;
    FResponseTruncation         : Boolean;
    FResponseRecursionAvailable : Boolean;
    FResponseQDCount            : Integer;
    FResponseANCount            : Integer;
    FResponseNSCount            : Integer;
    FResponseARCount            : Integer;
    FQuestionType               : Integer;
    FQuestionClass              : Integer;
    FQuestionName               : String;
    FAnswerNameArray            : TDnsAnswerNameArray;
    FAnswerTypeArray            : TDnsAnswerTypeArray;
    FAnswerClassArray           : TDnsAnswerClassArray;
    FAnswerTTLArray             : TDnsAnswerTTLArray;
    FAnswerTagArray             : TDnsAnswerTagArray;
    FMXRecordCount              : Integer;
    FMXPreferenceArray          : TDnsMXPreferenceArray;
    FMXExchangeArray            : TDnsMXExchangeArray;
    FARecordCount               : Integer;
    FAddressArray               : TDnsAddressArray;
    FOnRequestDone              : TDnsRequestDoneEvent;
    function GetMXPreference(nIndex : Integer) : Integer;
    function GetMXExchange(nIndex : Integer) : String;
    function GetAnswerName(nIndex : Integer) : String;
    function GetAnswerType(nIndex : Integer) : Integer;
    function GetAnswerClass(nIndex : Integer) : Integer;
    function GetAnswerTTL(nIndex : Integer) : LongInt;
    function GetAnswerTag(nIndex : Integer) : Integer;
    function GetAddress(nIndex : Integer) : TInAddr;
    procedure BuildRequestHeader(Dst       : PDnsRequestHeader;
                                 ID        : WORD;
                                 OPCode    : BYTE;
                                 Recursion : Boolean;
                                 QDCount   : WORD;
                                 ANCount   : WORD;
                                 NSCount   : WORD;
                                 ARCount   : WORD); virtual;
    function  BuildQuestionSection(Dst         : PChar;
                                   const QName : String;
                                   QType       : WORD;
                                   QClass      : WORD) : Integer; virtual;
    procedure WSocketDataAvailable(Sender: TRtcConnection); virtual;
    procedure TriggerRequestDone(Error: WORD); virtual;
    function  GetResponseBuf : PChar;
    procedure SendQuery;
    function  ExtractName(Base       : PChar;
                          From       : PChar;
                          var Name   : String) : PChar;
    function  DecodeQuestion(Base       : PChar;
                             From       : PChar;
                             var Name   : String;
                             var QType  : Integer;
                             var QClass : Integer) : PChar;
    function DecodeAnswer(Base         : PChar;
                          From         : PChar;
                          var Name     : String;
                          var QType    : Integer;
                          var QClass   : Integer;
                          var TTL      : LongInt;
                          var RDataPtr : Pointer;
                          var RDataLen : Integer) : PChar;
    function DecodeMXData(Base           : PChar;
                          From           : PChar;
                          var Preference : Integer;
                          var Exchange   : String) : PChar;
    function DecodeAData(Base        : PChar;
                         From        : PChar;
                         var Address : TInAddr) : PChar;
  public
    constructor Create(AOwner : TComponent); override;
    destructor  Destroy; override;
    procedure   Notification(AComponent: TComponent; operation: TOperation); override;
    function    MXLookup(Domain : String) : Integer;
    function    ALookup(Host : String) : Integer;
    property ResponseID                 : Integer read FResponseID;
    property ResponseCode               : Integer read FResponseCode;
    property ResponseOpCode             : Integer read FResponseOpCode;
    property ResponseAuthoritative      : Boolean read FResponseAuthoritative;
    property ResponseTruncation         : Boolean read FResponseTruncation;
    property ResponseRecursionAvailable : Boolean read FResponseRecursionAvailable;
    property ResponseQDCount            : Integer read FResponseQDCount;
    property ResponseANCount            : Integer read FResponseANCount;
    property ResponseNSCount            : Integer read FResponseNSCount;
    property ResponseARCount            : Integer read FResponseARCount;
    property ResponseBuf                : PChar   read GetResponseBuf;
    property ResponseLen                : Integer read FResponseLen;
    property QuestionType               : Integer read FQuestionType;
    property QuestionClass              : Integer read FQuestionClass;
    property QuestionName               : String  read FQuestionName;
    property AnswerName[nIndex : Integer]   : String  read GetAnswerName;
    property AnswerType[nIndex : Integer]   : Integer read GetAnswerType;
    property AnswerClass[nIndex : Integer]  : Integer read GetAnswerClass;
    property AnswerTTL[nIndex : Integer]    : LongInt read GetAnswerTTL;
    property AnswerTag[nIndex : Integer]    : Integer read GetAnswerTag;
    property MXPreference[nIndex : Integer] : Integer read GetMXPreference;
    property MXExchange[nIndex : Integer]   : String  read GetMXExchange;
    property Address[nIndex : Integer]      : TInAddr read GetAddress;
  published
    property Port    : String read  FPort write FPort;
    property Addr    : String read  FAddr write FAddr;
    property OnRequestDone : TDnsRequestDoneEvent read  FOnRequestDone
                                                  write FOnRequestDone;
  end;

implementation

type
    PWORD  = ^WORD;
    PDWORD = ^DWORD;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TRtcDnsQuery.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
    FWSocket := TRtcUdpClient.New;
    FPort    := '53';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TRtcDnsQuery.Destroy;
begin
    if Assigned(FWSocket) then begin
        FWSocket.Destroy;
        FWSocket := nil;
    end;
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRtcDnsQuery.Notification(AComponent: TComponent; operation: TOperation);
begin
    inherited Notification(AComponent, operation);
    if operation = opRemove then begin
        if AComponent = FWSocket then
            FWSocket := nil;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetMXPreference(nIndex : Integer) : Integer;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FMXPreferenceArray)) or
       (nIndex > High(FMXPreferenceArray)) then
        Result := 0
    else
        Result := FMXPreferenceArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetMXExchange(nIndex : Integer) : String;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FMXExchangeArray)) or
       (nIndex > High(FMXExchangeArray)) then
        Result := ''
    else
        Result := FMXExchangeArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetAnswerName(nIndex : Integer) : String;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FAnswerNameArray)) or
       (nIndex > High(FAnswerNameArray)) then
        Result := ''
    else
        Result := FAnswerNameArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetAnswerType(nIndex : Integer) : Integer;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FAnswerTypeArray)) or
       (nIndex > High(FAnswerTypeArray)) then
        Result := 0
    else
        Result := FAnswerTypeArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetAnswerClass(nIndex : Integer) : Integer;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FAnswerClassArray)) or
       (nIndex > High(FAnswerClassArray)) then
        Result := 0
    else
        Result := FAnswerClassArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetAnswerTTL(nIndex : Integer) : LongInt;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FAnswerTTLArray)) or
       (nIndex > High(FAnswerTTLArray)) then
        Result := 0
    else
        Result := FAnswerTTLArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetAnswerTag(nIndex : Integer) : Integer;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FAnswerTagArray)) or
       (nIndex > High(FAnswerTagArray)) then
        Result := 0
    else
        Result := FAnswerTagArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetAddress(nIndex : Integer) : TInAddr;
begin
    { Silently ignore index out of bounds error }
    if (nIndex < Low(FAddressArray)) or