dnssend.pas

snmp设计增加相应SNMP的OID,是实时处理的.

{==============================================================================|
| Project : Ararat Synapse                                       | 002.006.000 |
|==============================================================================|
| Content: DNS client                                                          |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2004.                |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}
{: @abstract(DNS client by UDP or TCP)
Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
 transfers too!

Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}

unit dnssend;

interface

uses
  SysUtils, Classes,
  blcksock, synautil, synsock;

const
  cDnsProtocol = 'domain';

  QTYPE_A = 1;
  QTYPE_NS = 2;
  QTYPE_MD = 3;
  QTYPE_MF = 4;
  QTYPE_CNAME = 5;
  QTYPE_SOA = 6;
  QTYPE_MB = 7;
  QTYPE_MG = 8;
  QTYPE_MR = 9;
  QTYPE_NULL = 10;
  QTYPE_WKS = 11; //
  QTYPE_PTR = 12;
  QTYPE_HINFO = 13;
  QTYPE_MINFO = 14;
  QTYPE_MX = 15;
  QTYPE_TXT = 16;

  QTYPE_RP = 17;
  QTYPE_AFSDB = 18;
  QTYPE_X25 = 19;
  QTYPE_ISDN = 20;
  QTYPE_RT = 21;
  QTYPE_NSAP = 22;
  QTYPE_NSAPPTR = 23;
  QTYPE_SIG = 24; // RFC-2065
  QTYPE_KEY = 25; // RFC-2065
  QTYPE_PX = 26;
  QTYPE_GPOS = 27;
  QTYPE_AAAA = 28;
  QTYPE_LOC = 29; // RFC-1876
  QTYPE_NXT = 30; // RFC-2065

  QTYPE_SRV = 33;
  QTYPE_NAPTR = 35; // RFC-2168
  QTYPE_KX = 36;

  QTYPE_AXFR = 252;
  QTYPE_MAILB = 253; //
  QTYPE_MAILA = 254; //
  QTYPE_ALL = 255;

type
  {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)

   Note: Are you missing properties for specify server address and port? Look to
   parent @link(TSynaClient) too!}
  TDNSSend = class(TSynaClient)
  private
    FID: Word;
    FRCode: Integer;
    FBuffer: AnsiString;
    FSock: TUDPBlockSocket;
    FTCPSock: TTCPBlockSocket;
    FUseTCP: Boolean;
    FAnsferInfo: TStringList;
    FNameserverInfo: TStringList;
    FAdditionalInfo: TStringList;
    FAuthoritative: Boolean;
    FTruncated: Boolean;
    function ReverseIP(Value: AnsiString): AnsiString;
    function ReverseIP6(Value: AnsiString): AnsiString;
    function CompressName(const Value: AnsiString): AnsiString;
    function CodeHeader: AnsiString;
    function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
    function DecodeLabels(var From: Integer): AnsiString;
    function DecodeString(var From: Integer): AnsiString;
    function DecodeResource(var i: Integer; const Info: TStringList;
      QType: Integer): AnsiString;
    function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
    function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
      QType: Integer):boolean;
  public
    constructor Create;
    destructor Destroy; override;

    {:Query a DNSHost for QType resources correspond to a name. Supported QType
     values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
     Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
     Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
     Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
     Qtype_KX.

     Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!

     "Name" is domain name or host name for queried resource. If "name" is
     IP address, automatically convert to reverse domain form (.in-addr.arpa).

     If result is @true, Reply contains resource records. One record on one line.
     If Resource record have multiple fields, they are stored on line divided by
     comma. (example: MX record contains value 'rs.cesnet.cz' with preference
     number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
     in resource are converted to string form.}
    function DNSQuery(Name: AnsiString; QType: Integer;
      const Reply: TStrings): Boolean;
  published

    {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
    property Sock: TUDPBlockSocket read FSock;

    {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
    property TCPSock: TTCPBlockSocket read FTCPSock;

    {:if @true, then is used TCP protocol instead UDP. It is needed for zone
     transfers, etc.}
    property UseTCP: Boolean read FUseTCP Write FUseTCP;

    {:After DNS operation contains ResultCode of DNS operation.
      Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
      4-not implemented, 5-refused.}
    property RCode: Integer read FRCode;

    {:@True, if ansfer is authoritative.}
    property Authoritative: Boolean read FAuthoritative;

    {:@True, if ansfer is truncated to 512 bytes.}
    property Truncated: Boolean read FTRuncated;

    {:Detailed informations from name server reply. One record per line. Record
     have comma delimited entries with type number, TTL and data filelds.
     This information contains detailed information about query reply.}
    property AnsferInfo: TStringList read FAnsferInfo;

    {:Detailed informations from name server reply. One record per line. Record
     have comma delimited entries with type number, TTL and data filelds.
     This information contains detailed information about nameserver.}
    property NameserverInfo: TStringList read FNameserverInfo;

    {:Detailed informations from name server reply. One record per line. Record
     have comma delimited entries with type number, TTL and data filelds.
     This information contains detailed additional information.}
    property AdditionalInfo: TStringList read FAdditionalInfo;
  end;

{:A very useful function, and example of it's use is found in the TDNSSend object.
 This function is used to get mail servers for a domain and sort them by
 preference numbers. "Servers" contains only the domain names of the mail
 servers in the right order (without preference number!). The first domain name
 will always be the highest preferenced mail server. Returns boolean @TRUE if
 all went well.}
function GetMailServers(const DNSHost, Domain: AnsiString;
  const Servers: TStrings): Boolean;

implementation

constructor TDNSSend.Create;
begin
  inherited Create;
  FSock := TUDPBlockSocket.Create;
  FTCPSock := TTCPBlockSocket.Create;
  FUseTCP := False;
  FTimeout := 10000;
  FTargetPort := cDnsProtocol;
  FAnsferInfo := TStringList.Create;
  FNameserverInfo := TStringList.Create;
  FAdditionalInfo := TStringList.Create;
  Randomize;
end;

destructor TDNSSend.Destroy;
begin
  FAnsferInfo.Free;
  FNameserverInfo.Free;
  FAdditionalInfo.Free;
  FTCPSock.Free;
  FSock.Free;
  inherited Destroy;
end;

function TDNSSend.ReverseIP(Value: AnsiString): AnsiString;
var
  x: Integer;
begin
  Result := '';
  repeat
    x := LastDelimiter('.', Value);
    Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
    Delete(Value, x, Length(Value) - x + 1);
  until x < 1;
  if Length(Result) > 0 then
    if Result[1] = '.' then
      Delete(Result, 1, 1);
end;

function TDNSSend.ReverseIP6(Value: AnsiString): AnsiString;
var
  ip6: TSockAddrIn6;
begin
  ip6 := FSock.StrToIP6(Value);
  Result := ip6.sin6_addr.S_un_b.s_b16
    + '.' + ip6.sin6_addr.S_un_b.s_b15
    + '.' + ip6.sin6_addr.S_un_b.s_b14
    + '.' + ip6.sin6_addr.S_un_b.s_b13
    + '.' + ip6.sin6_addr.S_un_b.s_b12
    + '.' + ip6.sin6_addr.S_un_b.s_b11
    + '.' + ip6.sin6_addr.S_un_b.s_b10
    + '.' + ip6.sin6_addr.S_un_b.s_b9
    + '.' + ip6.sin6_addr.S_un_b.s_b8
    + '.' + ip6.sin6_addr.S_un_b.s_b7
    + '.' + ip6.sin6_addr.S_un_b.s_b6
    + '.' + ip6.sin6_addr.S_un_b.s_b5
    + '.' + ip6.sin6_addr.S_un_b.s_b4
    + '.' + ip6.sin6_addr.S_un_b.s_b3
    + '.' + ip6.sin6_addr.S_un_b.s_b2
    + '.' + ip6.sin6_addr.S_un_b.s_b1;
end;

function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
var
  n: Integer;
  s: AnsiString;
begin
  Result := '';
  if Value = '' then
    Result := #0
  else
  begin
    s := '';
    for n := 1 to Length(Value) do
      if Value[n] = '.' then
      begin
        Result := Result + Char(Length(s)) + s;
        s := '';
      end
      else
        s := s + Value[n];
    if s <> '' then
      Result := Result + Char(Length(s)) + s;
    Result := Result + #0;
  end;
end;

function TDNSSend.CodeHeader: AnsiString;
begin
  FID := Random(32767);
  Result := CodeInt(FID); // ID
  Result := Result + CodeInt($0100); // flags
  Result := Result + CodeInt(1); // QDCount
  Result := Result + CodeInt(0); // ANCount
  Result := Result + CodeInt(0); // NSCount
  Result := Result + CodeInt(0); // ARCount
end;

function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
begin
  Result := CompressName(Name);
  Result := Result + CodeInt(QType);
  Result := Result + CodeInt(1); // Type INTERNET
end;

function TDNSSend.DecodeString(var From: Integer): AnsiString;
var
  Len: integer;
begin
  Len := Ord(FBuffer[From]);
  Inc(From);
  Result := Copy(FBuffer, From, Len);
  Inc(From, Len);
end;

function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
var