rtcdnsquery.pas

Delphi快速开发Web Server

       (nIndex > High(FAddressArray)) then
        Result.S_addr := 0
    else
        Result := FAddressArray[nIndex];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.GetResponseBuf : PChar;
begin
    Result := @FResponseBuf;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.MXLookup(Domain : String) : Integer;
begin
   Inc(FIDCount);
   BuildRequestHeader(PDnsRequestHeader(@FQueryBuf), FIDCount, DnsOpCodeQuery, TRUE, 1, 0, 0, 0);
   FQueryLen := BuildQuestionSection(@FQueryBuf[SizeOf(TDnsRequestHeader)], Domain, DnsQueryMX, DnsClassIN);
   FQueryLen := FQueryLen + SizeOf(TDnsRequestHeader);
   Result    := FIDCount;
   SendQuery;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.ALookup(Host : String) : Integer;
begin
   Inc(FIDCount);
   BuildRequestHeader(PDnsRequestHeader(@FQueryBuf), FIDCount, DnsOpCodeQuery, TRUE, 1, 0, 0, 0);
   FQueryLen := BuildQuestionSection(@FQueryBuf[SizeOf(TDnsRequestHeader)], Host, DnsQueryA, DnsClassIN);
   FQueryLen := FQueryLen + SizeOf(TDnsRequestHeader);
   Result    := FIDCount;
   SendQuery;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRtcDnsQuery.SendQuery;
var
  s:string;
begin
   FResponseLen             := -1;
   FWSocket.OnDataReceived := WSocketDataAvailable;
   FWSocket.ServerPort            := FPort;
   FWSocket.ServerAddr            := FAddr;
   FWSocket.Connect;

   SetLength(s,FQueryLen);
   Move(FQueryBuf[0],s[1],FQueryLen);
   FWSocket.Write(s);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.BuildQuestionSection(
    Dst         : PChar;
    const QName : String;
    QType       : WORD;
    QClass      : WORD) : Integer;
var
    I   : Integer;
    p   : PChar;
    Ptr : PChar;
begin
    Ptr := Dst;
    if Ptr = nil then begin
        Result := 0;
        Exit;
    end;
    I := 1;
    while I <= Length(QName) do begin
        p := Ptr;
        Inc(Ptr);
        while (I <= Length(QName)) and (QName[I] <> '.') do begin
            Ptr^ := QName[I];
            Inc(Ptr);
            Inc(I);
        end;
        p^ := Chr(Ptr - p - 1);
        Inc(I);
    end;
    Ptr^ := #0;
    Inc(Ptr);
    PWORD(Ptr)^ := WSocket_htons(QType);
    Inc(Ptr, 2);
    PWORD(Ptr)^ := WSocket_htons(QClass);
    Inc(Ptr, 2);
    Result := Ptr - Dst;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRtcDnsQuery.BuildRequestHeader(
    Dst       : PDnsRequestHeader;
    ID        : WORD;
    OPCode    : BYTE;
    Recursion : Boolean;
    QDCount   : WORD;
    ANCount   : WORD;
    NSCount   : WORD;
    ARCount   : WORD);
begin
    if Dst = nil then
        Exit;

    WinSockLoad;
    
    Dst^.ID      := WSocket_htons(ID);
    Dst^.Flags   := WSocket_htons((OpCode shl 11) + (Ord(Recursion) shl 8));
    Dst^.QDCount := WSocket_htons(QDCount);
    Dst^.ANCount := WSocket_htons(ANCount);
    Dst^.NSCount := WSocket_htons(NSCount);
    Dst^.ARCount := WSocket_htons(ARCount);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRtcDnsQuery.TriggerRequestDone(Error: WORD);
begin
    if Assigned(FOnRequestDone) then
        FOnRequestDone(Self, Error);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRtcDnsQuery.WSocketDataAvailable(Sender: TRtcConnection);
var
    Len    : Integer;
    Ans    : PDnsRequestHeader;
    Flags  : Integer;
    P      : PChar;
    RDataPtr : Pointer;
    RDataLen : Integer;
    I        : Integer;
    s:string;
begin
    Ans := PDnsRequestHeader(@FResponseBuf);

    // Len := FWSocket.Receive(Ans, SizeOf(FResponseBuf));
    {if Error <> 0 then begin
        TriggerRequestDone(Error);
        Exit;
    end;}

    s:=FWSocket.Read;
    Len:=length(s);
    if Len < SizeOf(TDnsRequestHeader) then
      Exit;
    Move(s[1],Ans^,SizeOf(FResponseBuf));

    { Check for minimum response length }
    Flags := WSocket_htons(Ans^.Flags);
    { Check if we got a response }
    if (Flags and $8000) = 0 then
        Exit;
    FResponseLen := Len;
    { Decode response header }
    FResponseID                 := WSocket_htons(Ans^.ID);
    FResponseCode               := Flags and $000F;
    FResponseOpCode             := (Flags shr 11) and $000F;
    FResponseAuthoritative      := (Flags and $0400) = $0400;
    FResponseTruncation         := (Flags and $0200) = $0200;
    FResponseRecursionAvailable := (Flags and $0080) = $0080;
    FResponseQDCount            := WSocket_ntohs(Ans^.QDCount);
    FResponseANCount            := WSocket_ntohs(Ans^.ANCount);
    FResponseNSCount            := WSocket_ntohs(Ans^.NSCount);
    FResponseARCount            := WSocket_ntohs(Ans^.ARCount);

    P := @ResponseBuf[SizeOf(TDnsRequestHeader)];
    if FResponseQDCount = 0 then begin
        { I don't think we could receive 0 questions }
        FQuestionName  := '';
        FQuestionType  := 0;
        FQuestionClass := 0;
    end
    else begin
        { Should never be greater than 1 because we sent only one question }
        P := DecodeQuestion(@FResponseBuf, P,
                            FQuestionName, FQuestionType, FQuestionClass);
    end;
    if FResponseANCount = 0 then begin
//        FAnswerName    := '';
//        FAnswerType    := 0;
//        FAnswerClass   := 0;
//        FAnswerTTL     := 0;
        RDataPtr       := nil;
        RDataLen       := 0;
        FMXRecordCount := 0;
    end
    else begin
        FMXRecordCount := 0;
        for I := 0 to FResponseANCount - 1 do begin
            P := DecodeAnswer(@FResponseBuf,        P,
                              FAnswerNameArray[I],  FAnswerTypeArray[I],
                              FAnswerClassArray[I], FAnswerTTLArray[I],
                              RDataPtr,             RDataLen);
            FAnswerTagArray[I] := -1;
            case FAnswerTypeArray[I] of
            DnsQueryMX:
                begin
                    if FMXRecordCount <= High(FMXPreferenceArray) then begin
                        FAnswerTagArray[I] := FMXRecordCount;
                        DecodeMXData(@FResponseBuf, RDataPtr,
                                     FMXPreferenceArray[FMXRecordCount],
                                     FMXExchangeArray[FMXRecordCount]);
                        Inc(FMXRecordCount);
                    end;
                end;
            DnsQueryA:
                begin
                    if FARecordCount <= High(FAddressArray) then begin
                        FAnswerTagArray[I] := FARecordCount;
                        DecodeAData(@FResponseBuf, RDataPtr,
                                    FAddressArray[FARecordCount]);
                        Inc(FARecordCount);
                    end;
                end;
            end;
        end;
    end;
    TriggerRequestDone(0);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.ExtractName(
    Base       : PChar;
    From       : PChar;
    var Name   : String) : PChar;
var
    N       : Integer;
    I       : Integer;
    P       : PChar;
    NameEnd : String;
begin
    P := From;
    if P^ = #0 then begin
        Name := '';
        Inc(P);
    end
    else begin
        Name := '';
        while TRUE do begin
            { Get name part length }
            N := Ord(P^);
            if (N and $C0) = $C0 then begin
                 { Message compression }
                 N := ((N and $3F) shl 8) + Ord(P[1]);
                 if Length(Name) = 0 then
                     ExtractName(Base, Base + N, Name)
                 else begin
                     ExtractName(Base, Base + N, NameEnd);
                     Name := Name + NameEnd;
                 end;
                 Inc(P, 2);
                 break;
            end;
            Inc(P);
            if N = 0 then
                break;
            { Copy name part }
            for I := 1 to N do begin
                Name := Name + P^;
                Inc(P);
            end;
            if P^ <> #0 then
                Name := Name + '.';
        end;
    end;
    Result := P;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.DecodeQuestion(
    Base       : PChar;
    From       : PChar;
    var Name   : String;
    var QType  : Integer;
    var QClass : Integer) : PChar;
var
    P : PChar;
begin
    P := ExtractName(Base, From, Name);
    QType  := WSocket_ntohs(PWORD(P)^);
    Inc(P, 2);
    QClass := WSocket_ntohs(PWORD(P)^);
    Inc(P, 2);
    Result := P;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.DecodeAnswer(
    Base         : PChar;
    From         : PChar;
    var Name     : String;
    var QType    : Integer;
    var QClass   : Integer;
    var TTL      : LongInt;
    var RDataPtr : Pointer;
    var RDataLen : Integer) : PChar;
var
    P : PChar;
begin
    P := ExtractName(Base, From, Name);
    QType  := WSocket_ntohs(PWORD(P)^);
    Inc(P, 2);
    QClass := WSocket_ntohs(PWORD(P)^);
    Inc(P, 2);
    TTL    := WSocket_ntohl(PDWORD(P)^);
    Inc(P, 4);
    RDataLen := WSocket_ntohs(PWORD(P)^);
    Inc(P, 2);
    RDataPtr := P;
    Result := P + RDataLen;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.DecodeMXData(
    Base           : PChar;
    From           : PChar;
    var Preference : Integer;
    var Exchange   : String) : PChar;
begin
    Result := From;
    Preference := WSocket_ntohs(PWORD(Result)^);
    Inc(Result, 2);
    Result := ExtractName(Base, Result, Exchange);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRtcDnsQuery.DecodeAData(
    Base        : PChar;
    From        : PChar;
    var Address : TInAddr) : PChar;
begin
    Result := From;
    Address.S_addr := PDWORD(Result)^;
    Inc(Result, 4);
end;

end.