1 { Copyright (C) 2005 Bas Steendijk and Peter Green
\r 
   2   For conditions of distribution and use, see copyright notice in zlib_license.txt
\r 
   3   which is included in the package
\r 
   4   ----------------------------------------------------------------------------- }
\r 
   8   code wanting to use this dns system should act as follows (note: app
\r 
   9   developers will probably want to use dnsasync or dnssync or write a similar
\r 
  10   wrapper unit of their own).
\r 
  12   for normal lookups call setstate_forward or setstate_reverse to set up the
\r 
  13   state, for more obscure lookups use setstate_request_init and fill in other
\r 
  14   relevant state manually.
\r 
  16   call state_process which will do processing on the information in the state
\r 
  17   and return an action
\r 
  18   action_ignore means that dnscore wants the code that calls it to go
\r 
  19   back to waiting for packets
\r 
  20   action_sendpacket means that dnscore wants the code that calls it to send
\r 
  21   the packet in sendpacket/sendpacketlen and then start (or go back to) listening
\r 
  23   action_done means the request has completed (either succeeded or failed)
\r 
  25   callers should resend the last packet they tried to send if they have not
\r 
  26   been asked to send a new packet for more than some timeout value they choose.
\r 
  28   when a packet is received the application should put the packet in
\r 
  29   recvbuf/recvbuflen , set state.parsepacket and call state_process again
\r 
  31   once the app gets action_done it can determine success or failure in the
\r 
  34   on failure state.resultstr will be an empty string and state.resultbin will
\r 
  35   be zeroed out (easily detected by the fact that it will have a family of 0)
\r 
  37   on success for a A or AAAA lookup state.resultstr will be an empty string
\r 
  38   and state.resultbin will contain the result (note: AAAA lookups require IPv6
\r 
  41   if an A lookup fails and the code is built with IPv6 enabled then the code
\r 
  42   will return any AAAA records with the same name. The reverse does not apply
\r 
  43   so if an application prefers IPv6 but wants IPv4 results as well it must
\r 
  44   check them separately.
\r 
  46   on success for any other type of lookup state.resultstr will be an empty
\r 
  48   note the state contains ansistrings, setstate_init with a null name parameter
\r 
  49   can be used to clean these up if required.
\r 
  51   callers may use setstate_failure to mark the state as failed themselves
\r 
  52   before passing it on to other code, for example this may be done in the event
\r 
  58   code is here to do hosts file lookups. this is not done automatically by
\r 
  59   dnscore, the caller (this is dnssync and dnsasync) has to call the hosts file
\r 
  60   functions if it wants hosts file lookups.
\r 
  62   the current implementation will automatically periodically reload the file into
\r 
  63   a fast lookup cache if the file changed.
\r 
  65   both forward and reverse lookups are supported.
\r 
  67   a single IP having multiple hostnames, so "192.0.2.1 foo bar" is supported.
\r 
  69   local hostnames under the locally configured domain (so domain "example.org",
\r 
  70   a "192.0.2.1 foo" entry causing "foo.example.org" to resolve) is not supported.
\r 
  74 {$ifdef fpc}{$mode delphi}{$endif}
\r 
  76 {$include lcoreconfig.inc}
\r 
  80 uses binipstuff,classes,pgtypes,lcorernd;
\r 
  82 var usewindns : boolean = {$ifdef mswindows}true{$else}false{$endif};
\r 
  83 {hint to users of this unit that they should use windows dns instead.
\r 
  84 May be disabled by applications if desired. (e.g. if setting a custom
\r 
  87 note: this unit will not be able to self populate it's dns server list on
\r 
  88 older versions of windows.}
\r 
  97 hint to users of this unit to how to deal with connecting to hostnames regarding ipv4 or ipv6 usage
\r 
  98 can be set by apps as desired
\r 
 100 var useaf:integer = useaf_default;
\r 
 103 (temporarily) use a different nameserver, regardless of the dnsserverlist
\r 
 105 var overridednsserver:ansistring;
\r 
 109   maxnamefieldlen=63;
\r 
 110   //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries
\r 
 111   //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway
\r 
 114   action_sendquery=2;
\r 
 127   {the maximum number of RR of a kind of purely an extra sanity check and could be omitted.
\r 
 128   before, i set it to 20, but valid replies can have more. dnscore only does udp requests,
\r 
 129   and ordinary DNS, so up to 512 bytes. the maximum number of A records that fits seems to be 29}
\r 
 131   retryafter=300000; //microseconds must be less than one second;
\r 
 132   timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)
\r 
 134   dvar=array[0..0] of byte;
\r 
 136   tdnspacket=packed record
\r 
 139     rrcount:array[0..3] of word;
\r 
 140     payload:array[0..511-12] of byte;
\r 
 147     recursioncount:integer;
\r 
 148     queryname:ansistring;
\r 
 150     parsepacket:boolean;
\r 
 151     resultstr:ansistring;
\r 
 153     resultlist:tbiniplist;
\r 
 154     resultaction:integer;
\r 
 155     numrr1:array[0..3] of integer;
\r 
 158     sendpacketlen:integer;
\r 
 159     sendpacket:tdnspacket;
\r 
 160     recvpacketlen:integer;
\r 
 161     recvpacket:tdnspacket;
\r 
 162     forwardfamily:integer;
\r 
 166     requesttypehi:byte;
\r 
 171     data:array[0..511] of byte;
\r 
 174   trrpointer=packed record
\r 
 181 //commenting out functions from interface that do not have documented semantics
\r 
 182 //and probably should not be called from outside this unit, reenable them
\r 
 183 //if you must but please document them at the same time --plugwash
\r 
 185 //function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;
\r 
 187 //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
\r 
 188 function makereversename(const binip:tbinip):ansistring;
\r 
 190 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);
\r 
 192 //set up state for a forward lookup. A family value of AF_INET6 will give only
\r 
 193 //ipv6 results. Any other value will give only ipv4 results
\r 
 194 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);
\r 
 196 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
\r 
 197 procedure setstate_failure(var state:tdnsstate);
\r 
 198 //procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
\r 
 200 //for custom raw lookups such as TXT, as desired by the user
\r 
 201 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);
\r 
 203 procedure state_process(var state:tdnsstate);
\r 
 205 //function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;
\r 
 207 procedure populatednsserverlist;
\r 
 208 procedure cleardnsservercache;
\r 
 211   dnsserverlist : tbiniplist;
\r 
 212   dnsserverlag:tlist;
\r 
 213 //  currentdnsserverno : integer;
\r 
 216 //getcurrentsystemnameserver returns the nameserver the app should use and sets
\r 
 217 //id to the id of that nameserver. id should later be used to report how laggy
\r 
 218 //the servers response was and if it was timed out.
\r 
 219 function getcurrentsystemnameserver(var id:integer) :ansistring;
\r 
 220 function getcurrentsystemnameserverbin(var id:integer) :tbinip;
\r 
 221 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
\r 
 224 //  unixnameservercache:string;
\r 
 229 procedure initpreferredmode;
\r 
 232   preferredmodeinited:boolean;
\r 
 237   failurereason:ansistring;
\r 
 239 function getquerytype(s:ansistring):integer;
\r 
 241 //optionally do any time consuming initing in advance, in case one wants the first dns lookup to be as fast as possible
\r 
 242 procedure dnscore_preinit(alsoreverse:boolean);
\r 
 245   hostsfile_inited:boolean;
\r 
 246   hostsfile_reverseinited:boolean;
\r 
 247   hostsfile_filename:ansistring;  //the app can change this, to use a custom hosts file
\r 
 248   hostsfile_entries:tstringlist;
\r 
 249   hostsfile_lastfileage:longint;  //fileage is longint on freepascal, integer on delphi
\r 
 250   hostsfile_lastcheckts:integer;
\r 
 251   hostsfile_reverseentries:tstringlist;
\r 
 253   //parameter settings
\r 
 254   hostsfile_disabled:boolean;  //the app can set this to disable all hosts file lookup functionality, including localhost
\r 
 255   hostsfile_onlylocalhost:boolean;  //the app can set this to disable the hosts file but keep localhost
\r 
 256   hostsfile_alsocustomserver:boolean;  //the app can set this to use hosts file functionality even when a custom nameserver is set
\r 
 257   hostsfile_manualreload:boolean;           //don't check if the hosts file changed and auto reload it, the app can call hostsfile_reload to reload
\r 
 259 procedure hostsfile_init;
\r 
 260 procedure hostsfile_initreverse;
\r 
 261 procedure hostsfile_reload;
\r 
 262 procedure hostsfile_reloadifneeded;
\r 
 263 procedure hostsfile_add(const name:ansistring;const ip:tbinip);
\r 
 264 function hostsfile_forwardlookuplist(const name:ansistring):tbiniplist;
\r 
 265 function hostsfile_reverselookup(ip:tbinip):ansistring;
\r 
 266 function gethostsfilename:ansistring;
\r 
 271   {$ifdef mswindows}windows,{$endif}
\r 
 272   {$ifdef unix}unix,{$endif}  
\r 
 279   pbiniplist=^tbiniplist;
\r 
 280   thostsfile_entry=record
\r 
 283   phostsfile_entry=^thostsfile_entry;
\r 
 285   thostsfile_reverseentry=record
\r 
 288   phostsfile_reverseentry=^thostsfile_reverseentry;
\r 
 291 function hostsfile_findbyname(const name:ansistring):integer;
\r 
 293   if not hostsfile_entries.Find(name,result) then begin
\r 
 294     if (copy(name,length(name),1) = '.') then begin
\r 
 295       //if the name has a trailing dot, try to find without it
\r 
 296       if not hostsfile_entries.Find(copy(name,1,length(name)-1),result) then result := -1;
\r 
 298       //if the name has no trailing dot, try to find with it
\r 
 299       if not hostsfile_entries.Find(name + '.',result) then result := -1;
\r 
 305 function hostsfile_forwardlookuplist(const name:ansistring):tbiniplist;
\r 
 311   index := hostsfile_findbyname(name);
\r 
 313   result := biniplist_new;
\r 
 315   if (index >= 0) then begin
\r 
 316     l := phostsfile_entry(hostsfile_entries.objects[index]).l;
\r 
 319     if (useaf <> useaf_v6) and (useaf <> useaf_preferv6) then
\r 
 322       addipsoffamily(result,l,af_inet);
\r 
 325     if (useaf <> useaf_v4) then begin
\r 
 326       addipsoffamily(result,l,af_inet6);
\r 
 327       if (useaf = useaf_preferv6) then begin
\r 
 328         addipsoffamily(result,l,af_inet);
\r 
 335 procedure hostsfile_clearreverse;
\r 
 339   for index := hostsfile_reverseentries.count-1 downto 0 do begin
\r 
 340     phostsfile_reverseentry(hostsfile_reverseentries.objects[index]).name := '';
\r 
 341     dispose(phostsfile_reverseentry(hostsfile_reverseentries.objects[index]));
\r 
 343   hostsfile_reverseentries.clear;
\r 
 347 procedure hostsfile_initreverse;
\r 
 349   index,index2:integer;
\r 
 351   a,countbefore:integer;
\r 
 354   he:phostsfile_reverseentry;
\r 
 357   if hostsfile_reverseinited then exit;
\r 
 358   hostsfile_reverseinited := true;
\r 
 360   hostsfile_clearreverse;
\r 
 362   //build fast search table for reverse lookups
\r 
 363   for index := hostsfile_entries.count-1 downto 0 do begin
\r 
 364     l := phostsfile_entry(hostsfile_entries.objects[index]).l;
\r 
 365     for a := biniplist_getcount(l)-1 downto 0 do begin
\r 
 366       ip := biniplist_get(l,a);
\r 
 367       s := ipbintostr(ip);
\r 
 369       countbefore := hostsfile_reverseentries.count;
\r 
 370       index2 := hostsfile_reverseentries.Add(s);
\r 
 371       if (hostsfile_reverseentries.count > countbefore) then begin
\r 
 373         hostsfile_reverseentries.objects[index2] := tobject(he);
\r 
 374         he.name := hostsfile_entries[index];
\r 
 381 function hostsfile_reverselookup(ip:tbinip):ansistring;
\r 
 386   hostsfile_initreverse;
\r 
 388   s := ipbintostr(ip);
\r 
 390   if hostsfile_reverseentries.find(s,index) then begin
\r 
 391     result := phostsfile_reverseentry(hostsfile_reverseentries.objects[index]).name;
\r 
 395 procedure hostsfile_clear;
\r 
 399   for index := hostsfile_entries.count-1 downto 0 do begin
\r 
 400     biniplist_free(phostsfile_entry(hostsfile_entries.objects[index]).l);
\r 
 401     dispose(phostsfile_entry(hostsfile_entries.objects[index]));
\r 
 403   hostsfile_entries.clear;
\r 
 405   hostsfile_clearreverse;
\r 
 407   hostsfile_lastfileage := 0;
\r 
 408   hostsfile_lastcheckts := 0;
\r 
 411 procedure hostsfile_add(const name:ansistring;const ip:tbinip);
\r 
 414   a,index,countbefore:integer;
\r 
 417   he:phostsfile_entry;
\r 
 421   countbefore := hostsfile_entries.count;
\r 
 422   //add, with dupignore, will add it if it's not in the list. if it is in the list, it returns the index
\r 
 423   //to know if it was added, see if the count went up. this saves on duplicate searches in the list, for speed
\r 
 424   index := hostsfile_entries.add(name);
\r 
 426   if (hostsfile_entries.count > countbefore) then begin
\r 
 427    // writeln('name newly added ',name,' ',ipbintostr(ip),' ',index);
\r 
 430     hostsfile_entries.objects[index] := tobject(he);
\r 
 431     he.l := biniplist_new;
\r 
 434    // writeln('name found ',name,' ',ipbintostr(ip),' ',index);
\r 
 435     //search for IP match
\r 
 437     he := phostsfile_entry(hostsfile_entries.objects[index]);
\r 
 439     for a := biniplist_getcount(l)-1 downto 0 do begin
\r 
 440       ip2 := biniplist_get(l,a);
\r 
 441       if comparebinip(ip,ip2) then begin
\r 
 442       //  writeln('duplicate ip ',name,' ',ipbintostr(ip));
\r 
 448   biniplist_add(he.l,ip);
\r 
 452 function getts:integer;
\r 
 455   result := GetTickCount;
\r 
 460   gettimemonotonic(temp);
\r 
 461   result := ((temp.tv_usec div 1000) + (temp.tv_sec * 1000));
\r 
 466 function gethostsfilename:ansistring;
\r 
 469   windir:array [0..255] of ansichar;
\r 
 471   GetSystemWindowsDirectoryA:function(buffer:pansichar;size:integer):integer; stdcall;
\r 
 473   OsVersion                  : TOSVersionInfo;
\r 
 475   filenamesuffix:ansistring;
\r 
 479     ZeroMemory(@OsVersion, SizeOf(OsVersion));
\r 
 480     OsVersion.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
\r 
 482     if ((GetVersionEx(OsVersion)) and (OsVersion.dwPlatformId = VER_PLATFORM_WIN32_NT)) then begin
\r 
 483       filenamesuffix := '\system32\drivers\etc\hosts';
\r 
 485       filenamesuffix := '\hosts';
\r 
 488     //first try "user" windows directory. on a multiuser this may not be c:\windows
\r 
 489     GetWindowsDirectoryA(windir,255);
\r 
 491     if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);
\r 
 492     result := result + filenamesuffix;
\r 
 494     if not fileexists(result) then begin
\r 
 495       //then try "system" windows directory which is typically c:\windows on a multiuser system
\r 
 496       dllhandle := loadlibrary('kernel32.dll');
\r 
 497       if (dllhandle <> 0) then begin
\r 
 498         GetSystemWindowsDirectoryA := getprocaddress(dllhandle,'GetSystemWindowsDirectoryA');
\r 
 499         if assigned(GetSystemWindowsDirectoryA) then begin
\r 
 500           GetSystemWindowsDirectoryA(windir,255);
\r 
 501           freelibrary(dllhandle);
\r 
 503           if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);
\r 
 504           result := result + filenamesuffix;
\r 
 510     result := '/etc/hosts';
\r 
 514 procedure hostsfile_reload;
\r 
 519   validchar:array[0..255] of boolean;
\r 
 520   ipv4char:array[0..255] of boolean;
\r 
 523   a,len,field,startindex,labellen:integer;
\r 
 524   lastwasspace,onlyipv4chars:boolean;
\r 
 525   ipstring,hostname:ansistring;
\r 
 530   if hostsfile_disabled then exit;
\r 
 531   hostsfile_reverseinited := false;
\r 
 533   //add builtin entries
\r 
 534   hostsfile_add('localhost',ipstrtobinf('127.0.0.1'));
\r 
 536   hostsfile_add('localhost',ipstrtobinf('::1'));
\r 
 539   if hostsfile_onlylocalhost then exit;
\r 
 541   if (hostsfile_filename = '') then hostsfile_filename := gethostsfilename;
\r 
 543   //DNS names can only contain lower and uppercase, digits, dash, and dot
\r 
 544   fillchar(validchar,sizeof(validchar),0);
\r 
 545   validchar[ord('.')] := true;
\r 
 546   validchar[ord('-')] := true;
\r 
 547   fillchar(validchar[48],10,1);
\r 
 548   fillchar(validchar[65],26,1);
\r 
 549   fillchar(validchar[97],26,1);
\r 
 551   //chars that can be in an ipv4 address: digits and dot
\r 
 552   fillchar(ipv4char,sizeof(ipv4char),0);
\r 
 553   ipv4char[ord('.')] := true;
\r 
 554   fillchar(ipv4char[48],10,1);
\r 
 556   hostsfile_lastfileage := fileage(hostsfile_filename);
\r 
 557   hostsfile_lastcheckts := getts;
\r 
 558   //writeln('------ reloading ',hostsfile_lastfileage);
\r 
 560     t := treadtxt.createf(hostsfile_filename);
\r 
 564   if not assigned(t) then exit;
\r 
 566   while not t.eof do begin
\r 
 570     if (len > 512) then goto lineend; //sanity check
\r 
 572     lastwasspace := true;
\r 
 574     onlyipv4chars := true;
\r 
 576     //one extra loop iteration at the end with a "pretend space" for easy parsing
\r 
 581     while (a <= len) do begin
\r 
 583       if (a >= len) then ch := ' ' else ch := s[a];
\r 
 585       if (ch = '#') then begin
\r 
 586         //pretend the start of a comment is a space and the end of the line
\r 
 591       if (ch = #9) or (ch = ' ') then begin
\r 
 592         if not (lastwasspace) then begin
\r 
 593           if (field = 0) then begin
\r 
 594             ipstring := copy(s,startindex,a - startindex);
\r 
 595           end else if (field >= 1) then begin
\r 
 596             //maximum length of hostname
\r 
 597             if (a - startindex) > 253 then goto lineend;
\r 
 599             //remove a trailing dot
\r 
 600             //if (labellen = 0) then dec(a);
\r 
 602             //hostname must not be an empty string
\r 
 603             if (a - startindex) < 1 then goto lineend;
\r 
 605             hostname := copy(s,startindex,a - startindex);
\r 
 607             //reject a hosts entry with a name that is a valid ipv4 address.
\r 
 608             //we don't need to check for ipv6 addresses because they have a colon and so aren't valid hostsnames
\r 
 609             //the windows resolver does allow it, but i think it has potential security issues
\r 
 610             if onlyipv4chars then if ipstrtobin(hostname,biniptemp) then goto lineend;
\r 
 612             if ipstrtobin(ipstring,biniptemp) then begin
\r 
 613               //writeln('!!!hosts file adding ip=',ipstring,'@host=',hostname,'@');
\r 
 615               hostsfile_add(hostname,biniptemp);
\r 
 624         lastwasspace := true;
\r 
 626         if lastwasspace then begin
\r 
 629           lastwasspace := false;
\r 
 632         //enforce valid characters in hostname
\r 
 633         if (field = 1) then begin
\r 
 634           if not validchar[ord(ch)] then goto lineend;
\r 
 635           onlyipv4chars := onlyipv4chars and ipv4char[ord(ch)];
\r 
 636           if (ch = '.') then begin
\r 
 637             if (labellen = 0) then goto lineend;
\r 
 641             if (labellen > 63) then goto lineend;
\r 
 653 procedure hostsfile_reloadifneeded;
\r 
 657   if (hostsfile_disabled or hostsfile_onlylocalhost or hostsfile_manualreload) then exit;
\r 
 658   if hostsfile_filename = '' then exit;
\r 
 661   //writeln('reloadifneeded ts=',ts,' oldts=',hostsfile_lastcheckts);
\r 
 662   if not ((ts > hostsfile_lastcheckts + 10000) or (ts < hostsfile_lastcheckts)) then exit;
\r 
 664   hostsfile_lastcheckts := ts;
\r 
 666   //writeln('reloadifneeded new=',fileage(hostsfile_filename),' old=',hostsfile_lastfileage);
\r 
 667   if fileage(hostsfile_filename) = hostsfile_lastfileage then exit;
\r 
 671 procedure hostsfile_init;
\r 
 673   //writeln('init ',hostsfile_inited);
\r 
 674   if hostsfile_inited then begin
\r 
 675     hostsfile_reloadifneeded;
\r 
 678   hostsfile_inited := true;
\r 
 679   hostsfile_entries := tstringlist.create;
\r 
 680   hostsfile_entries.casesensitive := false;
\r 
 681   hostsfile_entries.sorted := true;
\r 
 682   hostsfile_entries.duplicates := dupignore;
\r 
 684   hostsfile_reverseentries := tstringlist.create;
\r 
 685   hostsfile_reverseentries.casesensitive := true;
\r 
 686   hostsfile_reverseentries.sorted := true;
\r 
 687   hostsfile_reverseentries.duplicates := dupignore;
\r 
 692 procedure dnscore_preinit(alsoreverse:boolean);
\r 
 698   populatednsserverlist;
\r 
 700   if alsoreverse then hostsfile_initreverse;
\r 
 704 function getquerytype(s:ansistring):integer;
\r 
 708   if (s = 'A') then result := querytype_a else
\r 
 709   if (s = 'CNAME') then result := querytype_cname else
\r 
 710   if (s = 'AAAA') then result := querytype_aaaa else
\r 
 711   if (s = 'PTR') then result := querytype_ptr else
\r 
 712   if (s = 'NS') then result := querytype_ns else
\r 
 713   if (s = 'MX') then result := querytype_mx else
\r 
 714   if (s = 'A6') then result := querytype_a6 else
\r 
 715   if (s = 'TXT') then result := querytype_txt else
\r 
 716   if (s = 'SOA') then result := querytype_soa else
\r 
 717   if (s = 'SPF') then result := querytype_spf;
\r 
 720 function buildrequest(const name:ansistring;var packet:tdnspacket;requesttype:word):integer;
\r 
 724   arr:array[0..sizeof(packet)-1] of byte absolute packet;
\r 
 726  { writeln('buildrequest: name: ',name);}
\r 
 728   fillchar(packet,sizeof(packet),0);
\r 
 729   packet.id := randominteger($10000);
\r 
 731   packet.flags := htons($0100);
\r 
 732   packet.rrcount[0] := htons($0001);
\r 
 735   s := copy(name,1,maxnamelength);
\r 
 736   if s = '' then exit;
\r 
 737   if s[length(s)] <> '.' then s := s + '.';
\r 
 740   if (s = '.') then begin
\r 
 741     packet.payload[0] := 0;
\r 
 744     for a := 1 to length(s) do begin
\r 
 745       if s[a] = '.' then begin
\r 
 746         if b > maxnamefieldlen then exit;
\r 
 747         if (b = 0) then exit;
\r 
 748         packet.payload[a-b-1] := b;
\r 
 751         packet.payload[a] := byte(s[a]);
\r 
 755     if b > maxnamefieldlen then exit;
\r 
 756     packet.payload[length(s)-b] := b;
\r 
 757     result := length(s) + 12+5;
\r 
 760   arr[result-1] := 1;
\r 
 761   arr[result-3] := requesttype and $ff;
\r 
 762   arr[result-4] := requesttype shr 8;
\r 
 765 function makereversename(const binip:tbinip):ansistring;
\r 
 771   if binip.family = AF_INET then begin
\r 
 772     b := htonl(binip.ip);
\r 
 773     for a := 0 to 3 do begin
\r 
 774       name := name + inttostr(b shr (a shl 3) and $ff)+'.';
\r 
 776     name := name + 'in-addr.arpa';
\r 
 779   if binip.family = AF_INET6 then begin
\r 
 780     for a := 15 downto 0 do begin
\r 
 781       b := binip.ip6.u6_addr8[a];
\r 
 782       name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';
\r 
 784     name := name + 'ip6.arpa';
\r 
 794 decodes DNS format name to a string. does not includes the root dot.
\r 
 795 doesnt read beyond len.
\r 
 796 empty result + non null failurereason: failure
\r 
 797 empty result + null failurereason: internal use
\r 
 799 function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):ansistring;
\r 
 801   arr:array[0..sizeof(packet)-1] of byte absolute packet;
\r 
 807     if (start+numread < 0) or (start+numread >= len) then begin
\r 
 809       failurereason := 'decoding name: got out of range1';
\r 
 812     b := arr[start+numread];
\r 
 813     if b >= $c0 then begin
\r 
 814       {recursive sub call}
\r 
 815       if recursion > 10 then begin
\r 
 817         failurereason := 'decoding name: max recursion';
\r 
 820       if ((start+numread+1) >= len) then begin
\r 
 822         failurereason := 'decoding name: got out of range3';
\r 
 825       a := ((b shl 8) or arr[start+numread+1]) and $3fff;
\r 
 826       s := decodename(packet,len,a,recursion+1,a);
\r 
 827       if (s = '') and (failurereason <> '') then begin
\r 
 831       if result <> '' then result := result + '.';
\r 
 832       result := result + s;
\r 
 835     end else if b < 64 then begin
\r 
 836       if (numread <> 0) and (b <> 0) then result := result + '.';
\r 
 837       for a := start+numread+1 to start+numread+b do begin
\r 
 838         if (a >= len) then begin
\r 
 840           failurereason := 'decoding name: got out of range2';
\r 
 843         result := result + ansichar(arr[a]);
\r 
 847       if b = 0 then begin
\r 
 848         if (result = '') and (recursion = 0) then result := '.';
\r 
 849         exit; {reached end of name}
\r 
 852       failurereason := 'decoding name: read invalid char';
\r 
 859 {==============================================================================}
\r 
 861 function getrawfromrr(const rrp:trrpointer;len:integer):ansistring;
\r 
 863   setlength(result,htons(trr(rrp.p^).datalen));
\r 
 864   uniquestring(result);
\r 
 865   move(trr(rrp.p^).data,result[1],length(result));
\r 
 869 function getipfromrr(const rrp:trrpointer;len:integer):tbinip;
\r 
 871   fillchar(result,sizeof(result),0);
\r 
 872   case trr(rrp.p^).requesttype of
\r 
 874       if htons(trr(rrp.p^).datalen) <> 4 then exit;
\r 
 875       move(trr(rrp.p^).data,result.ip,4);
\r 
 876       result.family :=AF_INET;
\r 
 879     querytype_aaaa: begin
\r 
 880       if htons(trr(rrp.p^).datalen) <> 16 then exit;
\r 
 881       result.family := AF_INET6;
\r 
 882       move(trr(rrp.p^).data,result.ip6,16);
\r 
 890 procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
\r 
 894   state.resultaction := action_done;
\r 
 895   state.resultstr := '';
\r 
 896   case trr(rrp.p^).requesttype of
\r 
 897     querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin
\r 
 898       state.resultbin := getipfromrr(rrp,len);
\r 
 900     querytype_txt:begin
\r 
 901       {TXT returns a raw string}
\r 
 902       state.resultstr := copy(getrawfromrr(rrp,len),2,9999);
\r 
 903       fillchar(state.resultbin,sizeof(state.resultbin),0);
\r 
 906       {MX is a name after a 16 bits word}
\r 
 907       state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);
\r 
 908       fillchar(state.resultbin,sizeof(state.resultbin),0);
\r 
 911     {other reply types (PTR, MX) return a hostname}
\r 
 912     state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);
\r 
 913     fillchar(state.resultbin,sizeof(state.resultbin),0);
\r 
 917 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);
\r 
 919   {destroy things properly}
\r 
 920   state.resultstr := '';
\r 
 921   state.queryname := '';
\r 
 922   state.rrdata := '';
\r 
 923   fillchar(state,sizeof(state),0);
\r 
 924   state.queryname := name;
\r 
 925   state.parsepacket := false;
\r 
 928 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);
\r 
 930   setstate_request_init(name,state);
\r 
 931   state.forwardfamily := family;
\r 
 933   if family = AF_INET6 then state.requesttype := querytype_aaaa else
\r 
 935   state.requesttype := querytype_a;
\r 
 938 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
\r 
 940   setstate_request_init(makereversename(binip),state);
\r 
 941   state.requesttype := querytype_ptr;
\r 
 944 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);
\r 
 946   setstate_request_init(name,state);
\r 
 947   state.requesttype := requesttype;
\r 
 951 procedure setstate_failure(var state:tdnsstate);
\r 
 953   state.resultstr := '';
\r 
 954   fillchar(state.resultbin,sizeof(state.resultbin),0);
\r 
 955   state.resultaction := action_done;
\r 
 958 procedure state_process(var state:tdnsstate);
\r 
 964   rrptemp:^trrpointer;
\r 
 966   if state.parsepacket then begin
\r 
 967     if state.recvpacketlen < 12 then begin
\r 
 968       failurereason := 'Undersized packet';
\r 
 969       state.resultaction := action_ignore;
\r 
 972     if state.id <> state.recvpacket.id then begin
\r 
 973       failurereason := 'ID mismatch';
\r 
 974       state.resultaction := action_ignore;
\r 
 978     for a := 0 to 3 do begin
\r 
 979       state.numrr1[a] := htons(state.recvpacket.rrcount[a]);
\r 
 980       if state.numrr1[a] > maxrrofakind then begin
\r 
 981         failurereason := 'exceeded maximum RR of a kind';
\r 
 984       inc(state.numrr2,state.numrr1[a]);
\r 
 987     setlength(state.rrdata,state.numrr2*sizeof(trrpointer));
\r 
 989     {- put all replies into a list}
\r 
 993     for a := 0 to state.numrr1[0]-1 do begin
\r 
 994       if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;
\r 
 995       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r 
 996       rrptemp.p := @state.recvpacket.payload[ofs-12];
\r 
 997       rrptemp.ofs := ofs;
\r 
 998       decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);
\r 
 999       rrptemp.len := b + 4;
\r 
1000       inc(ofs,rrptemp.len);
\r 
1003     for a := state.numrr1[0] to state.numrr2-1 do begin
\r 
1004       if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;
\r 
1005       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r 
1006       if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;
\r 
1007       rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}
\r 
1008       rrptemp.p := rrtemp;
\r 
1009       rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}
\r 
1010       rrptemp.namelen := b;
\r 
1011       b := htons(rrtemp.datalen);
\r 
1012       rrptemp.len := b + 10 + rrptemp.namelen;
\r 
1013       inc(ofs,rrptemp.len);
\r 
1015     if (ofs <> state.recvpacketlen) then begin
\r 
1016       failurereason := 'ofs <> state.packetlen';
\r 
1020     {if we requested A or AAAA build a list of all replies}
\r 
1021     if (state.requesttype = querytype_a) or (state.requesttype = querytype_aaaa) then begin
\r 
1022       state.resultlist := biniplist_new;
\r 
1023       for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
\r 
1024         rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r 
1025         rrtemp := rrptemp.p;
\r 
1027         if rrtemp.requesttype = state.requesttype then begin
\r 
1028           biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));
\r 
1033     {- check for items of the requested type in answer section, if so return success first}
\r 
1034     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
\r 
1035       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r 
1036       rrtemp := rrptemp.p;
\r 
1038       if rrtemp.requesttype = state.requesttype then begin
\r 
1039         setstate_return(rrptemp^,b,state);
\r 
1044     {if no items of correct type found, follow first cname in answer section}
\r 
1045     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
\r 
1046       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r 
1047       rrtemp := rrptemp.p;
\r 
1049       if rrtemp.requesttype = querytype_cname then begin
\r 
1050         state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);
\r 
1055     {no cnames found, no items of correct type found}
\r 
1056     if state.forwardfamily <> 0 then goto failure;
\r 
1060     {here it needs recursed lookup}
\r 
1061     {if needing to follow a cname, change state to do so}
\r 
1062     inc(state.recursioncount);
\r 
1063     if state.recursioncount > maxrecursion then goto failure;
\r 
1066   {here, a name needs to be resolved}
\r 
1067   if state.queryname = '' then begin
\r 
1068     failurereason := 'empty query name';
\r 
1072   state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);
\r 
1073   if state.sendpacketlen = 0 then begin
\r 
1074     failurereason := 'building request packet failed';
\r 
1077   state.id := state.sendpacket.id;
\r 
1078   state.resultaction := action_sendquery;
\r 
1082   setstate_failure(state);
\r 
1086 procedure populatednsserverlist;
\r 
1090   if assigned(dnsserverlag) then begin
\r 
1091     dnsserverlag.clear;
\r 
1093     dnsserverlag := tlist.Create;
\r 
1096   dnsserverlist := getsystemdnsservers;
\r 
1097   for a := biniplist_getcount(dnsserverlist)-1 downto 0 do dnsserverlag.Add(nil);
\r 
1100 procedure cleardnsservercache;
\r 
1102   if assigned(dnsserverlag) then begin
\r 
1103     dnsserverlag.destroy;
\r 
1104     dnsserverlag := nil;
\r 
1105     dnsserverlist := '';
\r 
1109 function getcurrentsystemnameserverbin(var id:integer):tbinip;
\r 
1111   counter : integer;
\r 
1113   {override the name server choice here, instead of overriding it wherever it's called
\r 
1114   setting ID to -1 causes it to be ignored in reportlag}
\r 
1115   if (overridednsserver <> '') then begin
\r 
1116     result := ipstrtobinf(overridednsserver);
\r 
1117     if result.family <> 0 then begin
\r 
1123   if not assigned(dnsserverlag) then populatednsserverlist;
\r 
1124   if dnsserverlag.count=0 then raise exception.create('no dns servers available');
\r 
1126   if dnsserverlag.count >1 then begin
\r 
1127     for counter := dnsserverlag.count-1 downto 1 do begin
\r 
1128       if taddrint(dnsserverlag[counter]) < taddrint(dnsserverlag[id]) then id := counter;
\r 
1131   result := biniplist_get(dnsserverlist,id);
\r 
1134 function getcurrentsystemnameserver(var id:integer):ansistring;
\r 
1136   result := ipbintostr(getcurrentsystemnameserverbin(id));
\r 
1139 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
\r 
1141   counter : integer;
\r 
1144   if (id < 0) or (id >= dnsserverlag.count) then exit;
\r 
1145   if lag = -1 then lag := timeoutlag;
\r 
1146   for counter := 0 to dnsserverlag.count-1 do begin
\r 
1147     temp := taddrint(dnsserverlag[counter]) *15;
\r 
1148     if counter=id then temp := temp + lag;
\r 
1149     dnsserverlag[counter] := tobject(temp div 16);
\r 
1157 procedure initpreferredmode;
\r 
1159   if preferredmodeinited then exit;
\r 
1160   if useaf <> useaf_default then exit;
\r 
1162   if (have_ipv6_connectivity) then
\r 
1163     useaf := useaf_preferv6
\r 
1165     useaf := useaf_preferv4;
\r 
1167   preferredmodeinited := true;
\r 
1173 {  quick and dirty description of dns packet structure to aid writing and
\r 
1174    understanding of parser code, refer to appropriate RFCs for proper specs
\r 
1175 - all words are network order
\r 
1177 www.google.com A request:
\r 
1179 0, 2: random transaction ID
\r 
1180 2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)
\r 
1181 4, 2: questions: 1
\r 
1182 6, 2: answer RR's: 0.
\r 
1183 8, 2: authority RR's: 0.
\r 
1184 10, 2: additional RR's: 0.
\r 
1187     #03 "www" #06 "google" #03 "com" #00
\r 
1188     size-4, 2: type: host address (1)
\r 
1189     size-2, 2: class: inet (1)
\r 
1193 0,2: random transaction ID
\r 
1194 2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)
\r 
1196 6,4: answer RR's: 2
\r 
1197 8,4: authority RR's: 9
\r 
1198 10,4: additional RR's: 9
\r 
1203     0,2 "c0 0c" "name: www.google.com"
\r 
1204     2,2 "00 05" "type: cname for an alias"
\r 
1205     4,2 "00 01" "class: inet"
\r 
1207     10,2: data length "00 17" (23)
\r 
1208     12: the cname name (www.google.akadns.net)
\r 
1211     2,2 "00 01" host address
\r 
1214     10,2: data length (4)
\r 
1216   authority - 9 records
\r 
1217   additional - 9 records
\r 
1223     4,2: class: inet (0001)
\r 
1225     10,2: data size (16)
\r 
1228   ptr request: query type 000c
\r 
1230 name compression: word "cxxx" in the name, xxx points to offset in the packet}
\r