{ Copyright (C) 2005 Bas Steendijk and Peter Green
  For conditions of distribution and use, see copyright notice in zlib_license.txt
  which is included in the package
  ----------------------------------------------------------------------------- }

{

  code wanting to use this dns system should act as follows (note: app
  developers will probably want to use dnsasync or dnssync or write a similar
  wrapper unit of their own).

  for normal lookups call setstate_forward or setstate_reverse to set up the
  state, for more obscure lookups use setstate_request_init and fill in other
  relevant state manually.

  call state_process which will do processing on the information in the state
  and return an action
  action_ignore means that dnscore wants the code that calls it to go
  back to waiting for packets
  action_sendpacket means that dnscore wants the code that calls it to send
  the packet in sendpacket/sendpacketlen and then start (or go back to) listening
  for
  action_done means the request has completed (either succeeded or failed)

  callers should resend the last packet they tried to send if they have not
  been asked to send a new packet for more than some timeout value they choose.

  when a packet is received the application should put the packet in
  recvbuf/recvbuflen , set state.parsepacket and call state_process again

  once the app gets action_done it can determine success or failure in the
  following ways.

  on failure state.resultstr will be an empty string and state.resultbin will
  be zeroed out (easily detected by the fact that it will have a family of 0)

  on success for a A or AAAA lookup state.resultstr will be an empty string
  and state.resultbin will contain the result (note: AAAA lookups require IPv6
  enabled).

  if an A lookup fails and the code is built with IPv6 enabled then the code
  will return any AAAA records with the same name. The reverse does not apply
  so if an application prefers IPv6 but wants IPv4 results as well it must
  check them separately.

  on success for any other type of lookup state.resultstr will be an empty

  note the state contains ansistrings, setstate_init with a null name parameter
  can be used to clean these up if required.

  callers may use setstate_failure to mark the state as failed themselves
  before passing it on to other code, for example this may be done in the event
  of a timeout.


  hosts file support:

  code is here to do hosts file lookups. this is not done automatically by
  dnscore, the caller (this is dnssync and dnsasync) has to call the hosts file
  functions if it wants hosts file lookups.

  the current implementation will automatically periodically reload the file into
  a fast lookup cache if the file changed.

  both forward and reverse lookups are supported.

  a single IP having multiple hostnames, so "192.0.2.1 foo bar" is supported.

  local hostnames under the locally configured domain (so domain "example.org",
  a "192.0.2.1 foo" entry causing "foo.example.org" to resolve) is not supported.
}
unit dnscore;

{$ifdef fpc}{$mode delphi}{$endif}

{$include lcoreconfig.inc}

interface

uses binipstuff,classes,pgtypes,lcorernd;

var usewindns : boolean = {$ifdef mswindows}true{$else}false{$endif};
{hint to users of this unit that they should use windows dns instead.
May be disabled by applications if desired. (e.g. if setting a custom
dnsserverlist).

note: this unit will not be able to self populate it's dns server list on
older versions of windows.}

const
  useaf_default=0;
  useaf_preferv4=1;
  useaf_preferv6=2;
  useaf_v4=3;
  useaf_v6=4;
{
hint to users of this unit to how to deal with connecting to hostnames regarding ipv4 or ipv6 usage
can be set by apps as desired
}
var useaf:integer = useaf_default;

{
(temporarily) use a different nameserver, regardless of the dnsserverlist
}
var overridednsserver:ansistring;

const
  maxnamelength=127;
  maxnamefieldlen=63;
  //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries
  //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway
  action_ignore=0;
  action_done=1;
  action_sendquery=2;
  querytype_a=1;
  querytype_cname=5;
  querytype_aaaa=28;
  querytype_a6=38;
  querytype_ptr=12;
  querytype_ns=2;
  querytype_soa=6;
  querytype_mx=15;
  querytype_txt=16;
  querytype_spf=99;
  maxrecursion=50;
  maxrrofakind=32;
  {the maximum number of RR of a kind of purely an extra sanity check and could be omitted.
  before, i set it to 20, but valid replies can have more. dnscore only does udp requests,
  and ordinary DNS, so up to 512 bytes. the maximum number of A records that fits seems to be 29}

  retryafter=300000; //microseconds must be less than one second;
  timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)
type
  dvar=array[0..0] of byte;
  pdvar=^dvar;
  tdnspacket=packed record
    id:word;
    flags:word;
    rrcount:array[0..3] of word;
    payload:array[0..511-12] of byte;
  end;



  tdnsstate=record
    id:word;
    recursioncount:integer;
    queryname:ansistring;
    requesttype:word;
    parsepacket:boolean;
    resultstr:ansistring;
    resultbin:tbinip;
    resultlist:tbiniplist;
    resultaction:integer;
    numrr1:array[0..3] of integer;
    numrr2:integer;
    rrdata:ansistring;
    sendpacketlen:integer;
    sendpacket:tdnspacket;
    recvpacketlen:integer;
    recvpacket:tdnspacket;
    forwardfamily:integer;
  end;

  trr=packed record
    requesttypehi:byte;
    requesttype:byte;
    clas:word;
    ttl:integer;
    datalen:word;
    data:array[0..511] of byte;
  end;

  trrpointer=packed record
    p:pointer;
    ofs:integer;
    len:integer;
    namelen:integer;
  end;

//commenting out functions from interface that do not have documented semantics
//and probably should not be called from outside this unit, reenable them
//if you must but please document them at the same time --plugwash

//function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;

//returns the DNS name used to reverse look up an IP, such as 4.3.2.1.in-addr.arpa for 1.2.3.4
function makereversename(const binip:tbinip):ansistring;

procedure setstate_request_init(const name:ansistring;var state:tdnsstate);

//set up state for a forward lookup. A family value of AF_INET6 will give only
//ipv6 results. Any other value will give only ipv4 results
procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);

procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
procedure setstate_failure(var state:tdnsstate);
//procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);

//for custom raw lookups such as TXT, as desired by the user
procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);

procedure state_process(var state:tdnsstate);

//function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;

procedure populatednsserverlist;
procedure cleardnsservercache;

var
  dnsserverlist : tbiniplist;
  dnsserverlag:tlist;
//  currentdnsserverno : integer;


//getcurrentsystemnameserver returns the nameserver the app should use and sets
//id to the id of that nameserver. id should later be used to report how laggy
//the servers response was and if it was timed out.
function getcurrentsystemnameserver(var id:integer) :ansistring;
function getcurrentsystemnameserverbin(var id:integer) :tbinip;
procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout

//var
//  unixnameservercache:string;
{ $endif}


{$ifdef ipv6}
procedure initpreferredmode;

var
  preferredmodeinited:boolean;

{$endif}

var
  failurereason:ansistring;

function getquerytype(s:ansistring):integer;

//optionally do any time consuming initing in advance, in case one wants the first dns lookup to be as fast as possible
procedure dnscore_preinit(alsoreverse:boolean);

var
  hostsfile_inited:boolean;
  hostsfile_reverseinited:boolean;
  hostsfile_filename:ansistring;  //the app can change this, to use a custom hosts file
  hostsfile_entries:tstringlist;
  hostsfile_lastfileage:longint;  //fileage is longint on freepascal, integer on delphi
  hostsfile_lastcheckts:integer;
  hostsfile_reverseentries:tstringlist;

  //parameter settings
  hostsfile_disabled:boolean;  //the app can set this to disable all hosts file lookup functionality, including localhost
  hostsfile_onlylocalhost:boolean;  //the app can set this to disable the hosts file but keep localhost
  hostsfile_alsocustomserver:boolean;  //the app can set this to use hosts file functionality even when a custom nameserver is set
  hostsfile_manualreload:boolean;           //don't check if the hosts file changed and auto reload it, the app can call hostsfile_reload to reload

procedure hostsfile_init;
procedure hostsfile_initreverse;
procedure hostsfile_reload;
procedure hostsfile_reloadifneeded;
procedure hostsfile_add(const name:ansistring;const ip:tbinip);
function hostsfile_forwardlookuplist(const name:ansistring):tbiniplist;
function hostsfile_reverselookup(ip:tbinip):ansistring;
function gethostsfilename:ansistring;

implementation

uses
  {$ifdef mswindows}windows,{$endif}
  {$ifdef unix}unix,{$endif}  
  lcorelocalips,
  readtxt2,
  ltimevalstuff,
  sysutils;

type
  pbiniplist=^tbiniplist;
  thostsfile_entry=record
    l:tbiniplist;
  end;
  phostsfile_entry=^thostsfile_entry;

  thostsfile_reverseentry=record
    name:ansistring;
  end;
  phostsfile_reverseentry=^thostsfile_reverseentry;


function hostsfile_findbyname(const name:ansistring):integer;
begin
  if not hostsfile_entries.Find(name,result) then begin
    if (copy(name,length(name),1) = '.') then begin
      //if the name has a trailing dot, try to find without it
      if not hostsfile_entries.Find(copy(name,1,length(name)-1),result) then result := -1;
    end else begin
      //if the name has no trailing dot, try to find with it
      if not hostsfile_entries.Find(name + '.',result) then result := -1;
    end;
  end;
end;


function hostsfile_forwardlookuplist(const name:ansistring):tbiniplist;
var
  index:integer;
  l:tbiniplist;
begin
  hostsfile_init;
  index := hostsfile_findbyname(name);

  result := biniplist_new;

  if (index >= 0) then begin
    l := phostsfile_entry(hostsfile_entries.objects[index]).l;

    {$ifdef ipv6}
    if (useaf <> useaf_v6) and (useaf <> useaf_preferv6) then
    {$endif}
    begin
      addipsoffamily(result,l,af_inet);
    end;
    {$ifdef ipv6}
    if (useaf <> useaf_v4) then begin
      addipsoffamily(result,l,af_inet6);
      if (useaf = useaf_preferv6) then begin
        addipsoffamily(result,l,af_inet);
      end;
    end;
    {$endif}
  end;
end;

procedure hostsfile_clearreverse;
var
  index:integer;
begin
  for index := hostsfile_reverseentries.count-1 downto 0 do begin
    phostsfile_reverseentry(hostsfile_reverseentries.objects[index]).name := '';
    dispose(phostsfile_reverseentry(hostsfile_reverseentries.objects[index]));
  end;
  hostsfile_reverseentries.clear;
end;


procedure hostsfile_initreverse;
var
  index,index2:integer;
  l:tbiniplist;
  a,countbefore:integer;
  ip:tbinip;
  s:ansistring;
  he:phostsfile_reverseentry;
begin
  hostsfile_init;
  if hostsfile_reverseinited then exit;
  hostsfile_reverseinited := true;

  hostsfile_clearreverse;

  //build fast search table for reverse lookups
  for index := hostsfile_entries.count-1 downto 0 do begin
    l := phostsfile_entry(hostsfile_entries.objects[index]).l;
    for a := biniplist_getcount(l)-1 downto 0 do begin
      ip := biniplist_get(l,a);
      s := ipbintostr(ip);

      countbefore := hostsfile_reverseentries.count;
      index2 := hostsfile_reverseentries.Add(s);
      if (hostsfile_reverseentries.count > countbefore) then begin
        new(he);
        hostsfile_reverseentries.objects[index2] := tobject(he);
        he.name := hostsfile_entries[index];
      end;

    end;
  end;
end;

function hostsfile_reverselookup(ip:tbinip):ansistring;
var
  index:integer;
  s:ansistring;
begin
  hostsfile_initreverse;
  result := '';
  s := ipbintostr(ip);

  if hostsfile_reverseentries.find(s,index) then begin
    result := phostsfile_reverseentry(hostsfile_reverseentries.objects[index]).name;
  end;
end;

procedure hostsfile_clear;
var
  index:integer;
begin
  for index := hostsfile_entries.count-1 downto 0 do begin
    biniplist_free(phostsfile_entry(hostsfile_entries.objects[index]).l);
    dispose(phostsfile_entry(hostsfile_entries.objects[index]));
  end;
  hostsfile_entries.clear;

  hostsfile_clearreverse;

  hostsfile_lastfileage := 0;
  hostsfile_lastcheckts := 0;
end;

procedure hostsfile_add(const name:ansistring;const ip:tbinip);
var

  a,index,countbefore:integer;

  ip2:tbinip;
  he:phostsfile_entry;
  l:tbiniplist;
begin

  countbefore := hostsfile_entries.count;
  //add, with dupignore, will add it if it's not in the list. if it is in the list, it returns the index
  //to know if it was added, see if the count went up. this saves on duplicate searches in the list, for speed
  index := hostsfile_entries.add(name);

  if (hostsfile_entries.count > countbefore) then begin
   // writeln('name newly added ',name,' ',ipbintostr(ip),' ',index);

    new(he);
    hostsfile_entries.objects[index] := tobject(he);
    he.l := biniplist_new;
    //he.name := name;
  end else begin
   // writeln('name found ',name,' ',ipbintostr(ip),' ',index);
    //search for IP match

    he := phostsfile_entry(hostsfile_entries.objects[index]);
    l := he.l;
    for a := biniplist_getcount(l)-1 downto 0 do begin
      ip2 := biniplist_get(l,a);
      if comparebinip(ip,ip2) then begin
      //  writeln('duplicate ip ',name,' ',ipbintostr(ip));
        exit; //duplicate
      end;
    end;
  end;
  //add it
  biniplist_add(he.l,ip);
end;


function getts:integer;
{$ifdef mswindows}
begin
  result := GetTickCount;
{$else}
var
  temp:ttimeval;
begin
  gettimemonotonic(temp);
  result := ((temp.tv_usec div 1000) + (temp.tv_sec * 1000));
{$endif}
end;


function gethostsfilename:ansistring;
var
{$ifdef mswindows}
  windir:array [0..255] of ansichar;

  GetSystemWindowsDirectoryA:function(buffer:pansichar;size:integer):integer; stdcall;
  dllhandle:thandle;
  OsVersion                  : TOSVersionInfo;
{$endif}
  filenamesuffix:ansistring;
begin
    {$ifdef mswindows}

    ZeroMemory(@OsVersion, SizeOf(OsVersion));
    OsVersion.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);

    if ((GetVersionEx(OsVersion)) and (OsVersion.dwPlatformId = VER_PLATFORM_WIN32_NT)) then begin
      filenamesuffix := '\system32\drivers\etc\hosts';
    end else begin
      filenamesuffix := '\hosts';
    end;

    //first try "user" windows directory. on a multiuser this may not be c:\windows
    GetWindowsDirectoryA(windir,255);
    result := windir;
    if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);
    result := result + filenamesuffix;

    if not fileexists(result) then begin
      //then try "system" windows directory which is typically c:\windows on a multiuser system
      dllhandle := loadlibrary('kernel32.dll');
      if (dllhandle <> 0) then begin
        GetSystemWindowsDirectoryA := getprocaddress(dllhandle,'GetSystemWindowsDirectoryA');
        if assigned(GetSystemWindowsDirectoryA) then begin
          GetSystemWindowsDirectoryA(windir,255);
          freelibrary(dllhandle);
          result := windir;
          if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);
          result := result + filenamesuffix;
        end;
      end;
    end;

    {$else}
    result := '/etc/hosts';
    {$endif}
end;

procedure hostsfile_reload;
label lineend;
var
  t:treadtxt;

  validchar:array[0..255] of boolean;
  ipv4char:array[0..255] of boolean;
  s:ansistring;
  ch:ansichar;
  a,len,field,startindex,labellen:integer;
  lastwasspace,onlyipv4chars:boolean;
  ipstring,hostname:ansistring;
  biniptemp:tbinip;
begin
  hostsfile_clear;

  if hostsfile_disabled then exit;
  hostsfile_reverseinited := false;

  //add builtin entries
  hostsfile_add('localhost',ipstrtobinf('127.0.0.1'));
  {$ifdef ipv6}
  hostsfile_add('localhost',ipstrtobinf('::1'));
  {$endif}

  if hostsfile_onlylocalhost then exit;

  if (hostsfile_filename = '') then hostsfile_filename := gethostsfilename;

  //DNS names can only contain lower and uppercase, digits, dash, and dot
  fillchar(validchar,sizeof(validchar),0);
  validchar[ord('.')] := true;
  validchar[ord('-')] := true;
  fillchar(validchar[48],10,1);
  fillchar(validchar[65],26,1);
  fillchar(validchar[97],26,1);

  //chars that can be in an ipv4 address: digits and dot
  fillchar(ipv4char,sizeof(ipv4char),0);
  ipv4char[ord('.')] := true;
  fillchar(ipv4char[48],10,1);

  hostsfile_lastfileage := fileage(hostsfile_filename);
  hostsfile_lastcheckts := getts;
  //writeln('------ reloading ',hostsfile_lastfileage);
  try
    t := treadtxt.createf(hostsfile_filename);
  except
    exit;
  end;
  if not assigned(t) then exit;

  while not t.eof do begin
    s := t.readline;

    len := length(s);
    if (len > 512) then goto lineend; //sanity check
    field := -1;
    lastwasspace := true;

    onlyipv4chars := true;

    //one extra loop iteration at the end with a "pretend space" for easy parsing
    inc(len);
    ipstring := '';
    hostname := '';
    a := 0;
    while (a <= len) do begin
      inc(a);
      if (a >= len) then ch := ' ' else ch := s[a];

      if (ch = '#') then begin
        //pretend the start of a comment is a space and the end of the line
        ch := ' ';
        len := a;
      end;

      if (ch = #9) or (ch = ' ') then begin
        if not (lastwasspace) then begin
          if (field = 0) then begin
            ipstring := copy(s,startindex,a - startindex);
          end else if (field >= 1) then begin
            //maximum length of hostname
            if (a - startindex) > 253 then goto lineend;

            //remove a trailing dot
            //if (labellen = 0) then dec(a);

            //hostname must not be an empty string
            if (a - startindex) < 1 then goto lineend;

            hostname := copy(s,startindex,a - startindex);

            //reject a hosts entry with a name that is a valid ipv4 address.
            //we don't need to check for ipv6 addresses because they have a colon and so aren't valid hostsnames
            //the windows resolver does allow it, but i think it has potential security issues
            if onlyipv4chars then if ipstrtobin(hostname,biniptemp) then goto lineend;

            if ipstrtobin(ipstring,biniptemp) then begin
              //writeln('!!!hosts file adding ip=',ipstring,'@host=',hostname,'@');

              hostsfile_add(hostname,biniptemp);
            end;

            //break scan loop
            //a := len;
          end;

        end;

        lastwasspace := true;
      end else begin
        if lastwasspace then begin
          inc(field);
          startindex := a;
          lastwasspace := false;
          labellen := 0;
        end;
        //enforce valid characters in hostname
        if (field = 1) then begin
          if not validchar[ord(ch)] then goto lineend;
          onlyipv4chars := onlyipv4chars and ipv4char[ord(ch)];
          if (ch = '.') then begin
            if (labellen = 0) then goto lineend;
            labellen := 0;
          end else begin
            inc(labellen);
            if (labellen > 63) then goto lineend;
          end;
        end;
      end;
    end;
lineend:
  end;
  t.destroy;

end;


procedure hostsfile_reloadifneeded;
var
  ts:integer;
begin
  if (hostsfile_disabled or hostsfile_onlylocalhost or hostsfile_manualreload) then exit;
  if hostsfile_filename = '' then exit;

  ts := getts;
  //writeln('reloadifneeded ts=',ts,' oldts=',hostsfile_lastcheckts);
  if not ((ts > hostsfile_lastcheckts + 10000) or (ts < hostsfile_lastcheckts)) then exit;

  hostsfile_lastcheckts := ts;

  //writeln('reloadifneeded new=',fileage(hostsfile_filename),' old=',hostsfile_lastfileage);
  if fileage(hostsfile_filename) = hostsfile_lastfileage then exit;
  hostsfile_reload;
end;

procedure hostsfile_init;
begin
  //writeln('init ',hostsfile_inited);
  if hostsfile_inited then begin
    hostsfile_reloadifneeded;
    exit;
  end;
  hostsfile_inited := true;
  hostsfile_entries := tstringlist.create;
  hostsfile_entries.casesensitive := false;
  hostsfile_entries.sorted := true;
  hostsfile_entries.duplicates := dupignore;

  hostsfile_reverseentries := tstringlist.create;
  hostsfile_reverseentries.casesensitive := true;
  hostsfile_reverseentries.sorted := true;
  hostsfile_reverseentries.duplicates := dupignore;

  hostsfile_reload;
end;

procedure dnscore_preinit(alsoreverse:boolean);
begin
  {$ifdef ipv6}
  initpreferredmode;
  {$endif}
  hostsfile_init;
  populatednsserverlist;
  randomdword;
  if alsoreverse then hostsfile_initreverse;
end;


function getquerytype(s:ansistring):integer;
begin
  s := uppercase(s);
  result := 0;
  if (s = 'A') then result := querytype_a else
  if (s = 'CNAME') then result := querytype_cname else
  if (s = 'AAAA') then result := querytype_aaaa else
  if (s = 'PTR') then result := querytype_ptr else
  if (s = 'NS') then result := querytype_ns else
  if (s = 'MX') then result := querytype_mx else
  if (s = 'A6') then result := querytype_a6 else
  if (s = 'TXT') then result := querytype_txt else
  if (s = 'SOA') then result := querytype_soa else
  if (s = 'SPF') then result := querytype_spf;
end;

function buildrequest(const name:ansistring;var packet:tdnspacket;requesttype:word):integer;
var
  a,b:integer;
  s:ansistring;
  arr:array[0..sizeof(packet)-1] of byte absolute packet;
begin
 { writeln('buildrequest: name: ',name);}
  result := 0;
  fillchar(packet,sizeof(packet),0);
  packet.id := randominteger($10000);

  packet.flags := htons($0100);
  packet.rrcount[0] := htons($0001);


  s := copy(name,1,maxnamelength);
  if s = '' then exit;
  if s[length(s)] <> '.' then s := s + '.';
  b := 0;
  {encode name}
  if (s = '.') then begin
    packet.payload[0] := 0;
    result := 12+5;
  end else begin
    for a := 1 to length(s) do begin
      if s[a] = '.' then begin
        if b > maxnamefieldlen then exit;
        if (b = 0) then exit;
        packet.payload[a-b-1] := b;
        b := 0;
      end else begin
        packet.payload[a] := byte(s[a]);
        inc(b);
      end;
    end;
    if b > maxnamefieldlen then exit;
    packet.payload[length(s)-b] := b;
    result := length(s) + 12+5;
  end;

  arr[result-1] := 1;
  arr[result-3] := requesttype and $ff;
  arr[result-4] := requesttype shr 8;
end;

function makereversename(const binip:tbinip):ansistring;
var
  name:ansistring;
  a,b:integer;
begin
  name := '';
  if binip.family = AF_INET then begin
    b := htonl(binip.ip);
    for a := 0 to 3 do begin
      name := name + inttostr(b shr (a shl 3) and $ff)+'.';
    end;
    name := name + 'in-addr.arpa';
  end else
  {$ifdef ipv6}
  if binip.family = AF_INET6 then begin
    for a := 15 downto 0 do begin
      b := binip.ip6.u6_addr8[a];
      name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';
    end;
    name := name + 'ip6.arpa';
  end else
  {$endif}
  begin
    {empty name}
  end;
  result := name;
end;

{
decodes DNS format name to a string. does not includes the root dot.
doesnt read beyond len.
empty result + non null failurereason: failure
empty result + null failurereason: internal use
}
function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):ansistring;
var
  arr:array[0..sizeof(packet)-1] of byte absolute packet;
  s:ansistring;
  a,b:integer;
begin
  numread := 0;
  repeat
    if (start+numread < 0) or (start+numread >= len) then begin
      result := '';
      failurereason := 'decoding name: got out of range1';
      exit;
    end;
    b := arr[start+numread];
    if b >= $c0 then begin
      {recursive sub call}
      if recursion > 10 then begin
        result := '';
        failurereason := 'decoding name: max recursion';
        exit;
      end;
      if ((start+numread+1) >= len) then begin
        result := '';
        failurereason := 'decoding name: got out of range3';
        exit;
      end;
      a := ((b shl 8) or arr[start+numread+1]) and $3fff;
      s := decodename(packet,len,a,recursion+1,a);
      if (s = '') and (failurereason <> '') then begin
        result := '';
        exit;
      end;
      if result <> '' then result := result + '.';
      result := result + s;
      inc(numread,2);
      exit;
    end else if b < 64 then begin
      if (numread <> 0) and (b <> 0) then result := result + '.';
      for a := start+numread+1 to start+numread+b do begin
        if (a >= len) then begin
          result := '';
          failurereason := 'decoding name: got out of range2';
          exit;
        end;
        result := result + ansichar(arr[a]);
      end;
      inc(numread,b+1);

      if b = 0 then begin
        if (result = '') and (recursion = 0) then result := '.';
        exit; {reached end of name}
      end;
    end else begin
      failurereason := 'decoding name: read invalid char';
      result := '';
      exit; {invalid}
    end;
  until false;
end;

{==============================================================================}

function getrawfromrr(const rrp:trrpointer;len:integer):ansistring;
begin
  setlength(result,htons(trr(rrp.p^).datalen));
  uniquestring(result);
  move(trr(rrp.p^).data,result[1],length(result));
end;


function getipfromrr(const rrp:trrpointer;len:integer):tbinip;
begin
  fillchar(result,sizeof(result),0);
  case trr(rrp.p^).requesttype of
    querytype_a: begin
      if htons(trr(rrp.p^).datalen) <> 4 then exit;
      move(trr(rrp.p^).data,result.ip,4);
      result.family :=AF_INET;
    end;
    {$ifdef ipv6}
    querytype_aaaa: begin
      if htons(trr(rrp.p^).datalen) <> 16 then exit;
      result.family := AF_INET6;
      move(trr(rrp.p^).data,result.ip6,16);
    end;
    {$endif}
  else
    {}
  end;
end;

procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
var
  a:integer;
begin
  state.resultaction := action_done;
  state.resultstr := '';
  case trr(rrp.p^).requesttype of
    querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin
      state.resultbin := getipfromrr(rrp,len);
    end;
    querytype_txt:begin
      {TXT returns a raw string}
      state.resultstr := copy(getrawfromrr(rrp,len),2,9999);
      fillchar(state.resultbin,sizeof(state.resultbin),0);
    end;
    querytype_mx:begin
      {MX is a name after a 16 bits word}
      state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);
      fillchar(state.resultbin,sizeof(state.resultbin),0);
    end;
  else
    {other reply types (PTR, MX) return a hostname}
    state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);
    fillchar(state.resultbin,sizeof(state.resultbin),0);
  end;
end;

procedure setstate_request_init(const name:ansistring;var state:tdnsstate);
begin
  {destroy things properly}
  state.resultstr := '';
  state.queryname := '';
  state.rrdata := '';
  fillchar(state,sizeof(state),0);
  state.queryname := name;
  state.parsepacket := false;
end;

procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);
begin
  setstate_request_init(name,state);
  state.forwardfamily := family;
  {$ifdef ipv6}
  if family = AF_INET6 then state.requesttype := querytype_aaaa else
  {$endif}
  state.requesttype := querytype_a;
end;

procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
begin
  setstate_request_init(makereversename(binip),state);
  state.requesttype := querytype_ptr;
end;

procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);
begin
  setstate_request_init(name,state);
  state.requesttype := requesttype;
end;


procedure setstate_failure(var state:tdnsstate);
begin
  state.resultstr := '';
  fillchar(state.resultbin,sizeof(state.resultbin),0);
  state.resultaction := action_done;
end;

procedure state_process(var state:tdnsstate);
label recursed;
label failure;
var
  a,b,ofs:integer;
  rrtemp:^trr;
  rrptemp:^trrpointer;
begin
  if state.parsepacket then begin
    if state.recvpacketlen < 12 then begin
      failurereason := 'Undersized packet';
      state.resultaction := action_ignore;
      exit;
    end;
    if state.id <> state.recvpacket.id then begin
      failurereason := 'ID mismatch';
      state.resultaction := action_ignore;
      exit;
    end;
    state.numrr2 := 0;
    for a := 0 to 3 do begin
      state.numrr1[a] := htons(state.recvpacket.rrcount[a]);
      if state.numrr1[a] > maxrrofakind then begin
        failurereason := 'exceeded maximum RR of a kind';
        goto failure;
      end;
      inc(state.numrr2,state.numrr1[a]);
    end;

    setlength(state.rrdata,state.numrr2*sizeof(trrpointer));

    {- put all replies into a list}

    ofs := 12;
    {get all queries}
    for a := 0 to state.numrr1[0]-1 do begin
      if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;
      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
      rrptemp.p := @state.recvpacket.payload[ofs-12];
      rrptemp.ofs := ofs;
      decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);
      rrptemp.len := b + 4;
      inc(ofs,rrptemp.len);
    end;

    for a := state.numrr1[0] to state.numrr2-1 do begin
      if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;
      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
      if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;
      rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}
      rrptemp.p := rrtemp;
      rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}
      rrptemp.namelen := b;
      b := htons(rrtemp.datalen);
      rrptemp.len := b + 10 + rrptemp.namelen;
      inc(ofs,rrptemp.len);
    end;
    if (ofs <> state.recvpacketlen) then begin
      failurereason := 'ofs <> state.packetlen';
      goto failure;
    end;

    {if we requested A or AAAA build a list of all replies}
    if (state.requesttype = querytype_a) or (state.requesttype = querytype_aaaa) then begin
      state.resultlist := biniplist_new;
      for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
        rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
        rrtemp := rrptemp.p;
        b := rrptemp.len;
        if rrtemp.requesttype = state.requesttype then begin
          biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));
        end;
      end;
    end;

    {- check for items of the requested type in answer section, if so return success first}
    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
      rrtemp := rrptemp.p;
      b := rrptemp.len;
      if rrtemp.requesttype = state.requesttype then begin
        setstate_return(rrptemp^,b,state);
        exit;
      end;
    end;

    {if no items of correct type found, follow first cname in answer section}
    for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
      rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
      rrtemp := rrptemp.p;
      b := rrptemp.len;
      if rrtemp.requesttype = querytype_cname then begin
        state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);
        goto recursed;
      end;
    end;

    {no cnames found, no items of correct type found}
    if state.forwardfamily <> 0 then goto failure;

    goto failure;
recursed:
    {here it needs recursed lookup}
    {if needing to follow a cname, change state to do so}
    inc(state.recursioncount);
    if state.recursioncount > maxrecursion then goto failure;
  end;

  {here, a name needs to be resolved}
  if state.queryname = '' then begin
    failurereason := 'empty query name';
    goto failure;
  end;

  state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);
  if state.sendpacketlen = 0 then begin
    failurereason := 'building request packet failed';
    goto failure;
  end;
  state.id := state.sendpacket.id;
  state.resultaction := action_sendquery;

  exit;
failure:
  setstate_failure(state);
end;


procedure populatednsserverlist;
var
  a:integer;
begin
  if assigned(dnsserverlag) then begin
    dnsserverlag.clear;
  end else begin
    dnsserverlag := tlist.Create;
  end;

  dnsserverlist := getsystemdnsservers;
  for a := biniplist_getcount(dnsserverlist)-1 downto 0 do dnsserverlag.Add(nil);
end;

procedure cleardnsservercache;
begin
  if assigned(dnsserverlag) then begin
    dnsserverlag.destroy;
    dnsserverlag := nil;
    dnsserverlist := '';
  end;
end;

function getcurrentsystemnameserverbin(var id:integer):tbinip;
var
  counter : integer;
begin
  {override the name server choice here, instead of overriding it wherever it's called
  setting ID to -1 causes it to be ignored in reportlag}
  if (overridednsserver <> '') then begin
    result := ipstrtobinf(overridednsserver);
    if result.family <> 0 then begin
      id := -1;
      exit;
    end;
  end;

  if not assigned(dnsserverlag) then populatednsserverlist;
  if dnsserverlag.count=0 then raise exception.create('no dns servers available');
  id := 0;
  if dnsserverlag.count >1 then begin
    for counter := dnsserverlag.count-1 downto 1 do begin
      if taddrint(dnsserverlag[counter]) < taddrint(dnsserverlag[id]) then id := counter;
    end;
  end;
  result := biniplist_get(dnsserverlist,id);
end;

function getcurrentsystemnameserver(var id:integer):ansistring;
begin
  result := ipbintostr(getcurrentsystemnameserverbin(id));
end;

procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
var
  counter : integer;
  temp : integer;
begin
  if (id < 0) or (id >= dnsserverlag.count) then exit;
  if lag = -1 then lag := timeoutlag;
  for counter := 0 to dnsserverlag.count-1 do begin
    temp := taddrint(dnsserverlag[counter]) *15;
    if counter=id then temp := temp + lag;
    dnsserverlag[counter] := tobject(temp div 16);
  end;

end;


{$ifdef ipv6}

procedure initpreferredmode;
begin
  if preferredmodeinited then exit;
  if useaf <> useaf_default then exit;

  if (have_ipv6_connectivity) then
    useaf := useaf_preferv6
  else
    useaf := useaf_preferv4;

  preferredmodeinited := true;
end;

{$endif}


{  quick and dirty description of dns packet structure to aid writing and
   understanding of parser code, refer to appropriate RFCs for proper specs
- all words are network order

www.google.com A request:

0, 2: random transaction ID
2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)
4, 2: questions: 1
6, 2: answer RR's: 0.
8, 2: authority RR's: 0.
10, 2: additional RR's: 0.
12, n: payload:
  query:
    #03 "www" #06 "google" #03 "com" #00
    size-4, 2: type: host address (1)
    size-2, 2: class: inet (1)

reply:

0,2: random transaction ID
2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)
4,4: questions: 1
6,4: answer RR's: 2
8,4: authority RR's: 9
10,4: additional RR's: 9
12: payload:
  query:
    ....
  answer: CNAME
    0,2 "c0 0c" "name: www.google.com"
    2,2 "00 05" "type: cname for an alias"
    4,2 "00 01" "class: inet"
    6,4: TTL
    10,2: data length "00 17" (23)
    12: the cname name (www.google.akadns.net)
  answer: A
    0,2 ..
    2,2 "00 01" host address
    4,2 ...
    6,4 ...
    10,2: data length (4)
    12,4: binary IP
  authority - 9 records
  additional - 9 records


  ipv6 AAAA reply:
    0,2: ...
    2,2: type: 001c
    4,2: class: inet (0001)
    6,2: TTL
    10,2: data size (16)
    12,16: binary IP

  ptr request: query type 000c

name compression: word "cxxx" in the name, xxx points to offset in the packet}

end.