dnscore.pas

   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
   5 \r
   6 {\r
   7 \r
   8   code wanting to use this dns system should act as follows (note: app\r
   9   developers will probablly want to use dnsasync or dnssync or write a similar\r
  10   wrapper unit of thier own).\r
  11 \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   relavent state manually.\r
  15 \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
  22   for\r
  23   action_done means the request has completed (either suceeded or failed)\r
  24 \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
  27 \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
  30 \r
  31   once the app gets action_done it can determine success or failure in the\r
  32   following ways.\r
  33 \r
  34   on failure state.resultstr will be an empty string and state.resultbin will\r
  35   be zeroed out (easilly detected by the fact that it will have a family of 0)\r
  36 \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
  39   enabled).\r
  40 \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 preffers IPV6 but wants IPV4 results as well it must\r
  44   check them seperately.\r
  45 \r
  46   on success for any other type of lookup state.resultstr will be an empty\r
  47 \r
  48   note the state contains ansistrings, setstate_init with a null name parameter\r
  49   can be used to clean theese up if required.\r
  50 \r
  51   callers may use setstate_failure to mark the state as failed themseleves\r
  52   before passing it on to other code, for example this may be done in the event\r
  53   of a timeout.\r
  54 }\r
  55 unit dnscore;\r
  56 \r
  57 {$ifdef fpc}{$mode delphi}{$endif}\r
  58 \r
  59 {$include lcoreconfig.inc}\r
  60 \r
  61 interface\r
  62 \r
  63 uses binipstuff,classes,pgtypes,lcorernd;\r
  64 \r
  65 var usewindns : boolean = {$ifdef win32}true{$else}false{$endif};\r
  66 {hint to users of this unit that they should use windows dns instead.\r
  67 May be disabled by applications if desired. (e.g. if setting a custom\r
  68 dnsserverlist).\r
  69 \r
  70 note: this unit will not be able to self populate it's dns server list on\r
  71 older versions of windows.}\r
  72 \r
  73 const\r
  74   useaf_default=0;\r
  75   useaf_preferv4=1;\r
  76   useaf_preferv6=2;\r
  77   useaf_v4=3;\r
  78   useaf_v6=4;\r
  79 {\r
  80 hint to users of this unit to how to deal with connecting to hostnames regarding ipv4 or ipv6 usage\r
  81 can be set by apps as desired\r
  82 }\r
  83 var useaf:integer = useaf_default;\r
  84 \r
  85 {\r
  86 (temporarily) use a different nameserver, regardless of the dnsserverlist\r
  87 }\r
  88 var overridednsserver:ansistring;\r
  89 \r
  90 const\r
  91   maxnamelength=127;\r
  92   maxnamefieldlen=63;\r
  93   //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries\r
  94   //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway\r
  95   action_ignore=0;\r
  96   action_done=1;\r
  97   action_sendquery=2;\r
  98   querytype_a=1;\r
  99   querytype_cname=5;\r
 100   querytype_aaaa=28;\r
 101   querytype_a6=38;\r
 102   querytype_ptr=12;\r
 103   querytype_ns=2;\r
 104   querytype_soa=6;\r
 105   querytype_mx=15;\r
 106   querytype_txt=16;\r
 107   querytype_spf=99;\r
 108   maxrecursion=50;\r
 109   maxrrofakind=20;\r
 110 \r
 111   retryafter=300000; //microseconds must be less than one second;\r
 112   timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)\r
 113 type\r
 114   dvar=array[0..0] of byte;\r
 115   pdvar=^dvar;\r
 116   tdnspacket=packed record\r
 117     id:word;\r
 118     flags:word;\r
 119     rrcount:array[0..3] of word;\r
 120     payload:array[0..511-12] of byte;\r
 121   end;\r
 122 \r
 123 \r
 124 \r
 125   tdnsstate=record\r
 126     id:word;\r
 127     recursioncount:integer;\r
 128     queryname:ansistring;\r
 129     requesttype:word;\r
 130     parsepacket:boolean;\r
 131     resultstr:ansistring;\r
 132     resultbin:tbinip;\r
 133     resultlist:tbiniplist;\r
 134     resultaction:integer;\r
 135     numrr1:array[0..3] of integer;\r
 136     numrr2:integer;\r
 137     rrdata:ansistring;\r
 138     sendpacketlen:integer;\r
 139     sendpacket:tdnspacket;\r
 140     recvpacketlen:integer;\r
 141     recvpacket:tdnspacket;\r
 142     forwardfamily:integer;\r
 143   end;\r
 144 \r
 145   trr=packed record\r
 146     requesttypehi:byte;\r
 147     requesttype:byte;\r
 148     clas:word;\r
 149     ttl:integer;\r
 150     datalen:word;\r
 151     data:array[0..511] of byte;\r
 152   end;\r
 153 \r
 154   trrpointer=packed record\r
 155     p:pointer;\r
 156     ofs:integer;\r
 157     len:integer;\r
 158     namelen:integer;\r
 159   end;\r
 160 \r
 161 //commenting out functions from interface that do not have documented semantics\r
 162 //and probablly should not be called from outside this unit, reenable them\r
 163 //if you must but please document them at the same time --plugwash\r
 164 \r
 165 //function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
 166 \r
 167 //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
 168 function makereversename(const binip:tbinip):ansistring;\r
 169 \r
 170 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);\r
 171 \r
 172 //set up state for a foward lookup. A family value of AF_INET6 will give only\r
 173 //ipv6 results. Any other value will give only ipv4 results\r
 174 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);\r
 175 \r
 176 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
 177 procedure setstate_failure(var state:tdnsstate);\r
 178 //procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
 179 \r
 180 //for custom raw lookups such as TXT, as desired by the user\r
 181 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);\r
 182 \r
 183 procedure state_process(var state:tdnsstate);\r
 184 \r
 185 //function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
 186 \r
 187 procedure populatednsserverlist;\r
 188 procedure cleardnsservercache;\r
 189 \r
 190 var\r
 191   dnsserverlist : tbiniplist;\r
 192   dnsserverlag:tlist;\r
 193 //  currentdnsserverno : integer;\r
 194 \r
 195 \r
 196 //getcurrentsystemnameserver returns the nameserver the app should use and sets\r
 197 //id to the id of that nameserver. id should later be used to report how laggy\r
 198 //the servers response was and if it was timed out.\r
 199 function getcurrentsystemnameserver(var id:integer) :ansistring;\r
 200 function getcurrentsystemnameserverbin(var id:integer) :tbinip;\r
 201 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
 202 \r
 203 //var\r
 204 //  unixnameservercache:string;\r
 205 { $endif}\r
 206 \r
 207 \r
 208 {$ifdef ipv6}\r
 209 procedure initpreferredmode;\r
 210 \r
 211 var\r
 212   preferredmodeinited:boolean;\r
 213 \r
 214 {$endif}\r
 215 \r
 216 var\r
 217   failurereason:ansistring;\r
 218 \r
 219 function getquerytype(s:ansistring):integer;\r
 220 \r
 221 implementation\r
 222 \r
 223 uses\r
 224   lcorelocalips,\r
 225   sysutils;\r
 226 \r
 227 \r
 228 \r
 229 function getquerytype(s:ansistring):integer;\r
 230 begin\r
 231   s := uppercase(s);\r
 232   result := 0;\r
 233   if (s = 'A') then result := querytype_a else\r
 234   if (s = 'CNAME') then result := querytype_cname else\r
 235   if (s = 'AAAA') then result := querytype_aaaa else\r
 236   if (s = 'PTR') then result := querytype_ptr else\r
 237   if (s = 'NS') then result := querytype_ns else\r
 238   if (s = 'MX') then result := querytype_mx else\r
 239   if (s = 'A6') then result := querytype_a6 else\r
 240   if (s = 'TXT') then result := querytype_txt else\r
 241   if (s = 'SOA') then result := querytype_soa else\r
 242   if (s = 'SPF') then result := querytype_spf;\r
 243 end;\r
 244 \r
 245 function buildrequest(const name:ansistring;var packet:tdnspacket;requesttype:word):integer;\r
 246 var\r
 247   a,b:integer;\r
 248   s:ansistring;\r
 249   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
 250 begin\r
 251  { writeln('buildrequest: name: ',name);}\r
 252   result := 0;\r
 253   fillchar(packet,sizeof(packet),0);\r
 254   packet.id := randominteger($10000);\r
 255 \r
 256   packet.flags := htons($0100);\r
 257   packet.rrcount[0] := htons($0001);\r
 258 \r
 259 \r
 260   s := copy(name,1,maxnamelength);\r
 261   if s = '' then exit;\r
 262   if s[length(s)] <> '.' then s := s + '.';\r
 263   b := 0;\r
 264   {encode name}\r
 265   if (s = '.') then begin\r
 266     packet.payload[0] := 0;\r
 267     result := 12+5;\r
 268   end else begin\r
 269     for a := 1 to length(s) do begin\r
 270       if s[a] = '.' then begin\r
 271         if b > maxnamefieldlen then exit;\r
 272         if (b = 0) then exit;\r
 273         packet.payload[a-b-1] := b;\r
 274         b := 0;\r
 275       end else begin\r
 276         packet.payload[a] := byte(s[a]);\r
 277         inc(b);\r
 278       end;\r
 279     end;\r
 280     if b > maxnamefieldlen then exit;\r
 281     packet.payload[length(s)-b] := b;\r
 282     result := length(s) + 12+5;\r
 283   end;\r
 284 \r
 285   arr[result-1] := 1;\r
 286   arr[result-3] := requesttype and $ff;\r
 287   arr[result-4] := requesttype shr 8;\r
 288 end;\r
 289 \r
 290 function makereversename(const binip:tbinip):ansistring;\r
 291 var\r
 292   name:ansistring;\r
 293   a,b:integer;\r
 294 begin\r
 295   name := '';\r
 296   if binip.family = AF_INET then begin\r
 297     b := htonl(binip.ip);\r
 298     for a := 0 to 3 do begin\r
 299       name := name + inttostr(b shr (a shl 3) and $ff)+'.';\r
 300     end;\r
 301     name := name + 'in-addr.arpa';\r
 302   end else\r
 303   {$ifdef ipv6}\r
 304   if binip.family = AF_INET6 then begin\r
 305     for a := 15 downto 0 do begin\r
 306       b := binip.ip6.u6_addr8[a];\r
 307       name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';\r
 308     end;\r
 309     name := name + 'ip6.arpa';\r
 310   end else\r
 311   {$endif}\r
 312   begin\r
 313     {empty name}\r
 314   end;\r
 315   result := name;\r
 316 end;\r
 317 \r
 318 {\r
 319 decodes DNS format name to a string. does not includes the root dot.\r
 320 doesnt read beyond len.\r
 321 empty result + non null failurereason: failure\r
 322 empty result + null failurereason: internal use\r
 323 }\r
 324 function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):ansistring;\r
 325 var\r
 326   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
 327   s:ansistring;\r
 328   a,b:integer;\r
 329 begin\r
 330   numread := 0;\r
 331   repeat\r
 332     if (start+numread < 0) or (start+numread >= len) then begin\r
 333       result := '';\r
 334       failurereason := 'decoding name: got out of range1';\r
 335       exit;\r
 336     end;\r
 337     b := arr[start+numread];\r
 338     if b >= $c0 then begin\r
 339       {recursive sub call}\r
 340       if recursion > 10 then begin\r
 341         result := '';\r
 342         failurereason := 'decoding name: max recursion';\r
 343         exit;\r
 344       end;\r
 345       if ((start+numread+1) >= len) then begin\r
 346         result := '';\r
 347         failurereason := 'decoding name: got out of range3';\r
 348         exit;\r
 349       end;\r
 350       a := ((b shl 8) or arr[start+numread+1]) and $3fff;\r
 351       s := decodename(packet,len,a,recursion+1,a);\r
 352       if (s = '') and (failurereason <> '') then begin\r
 353         result := '';\r
 354         exit;\r
 355       end;\r
 356       if result <> '' then result := result + '.';\r
 357       result := result + s;\r
 358       inc(numread,2);\r
 359       exit;\r
 360     end else if b < 64 then begin\r
 361       if (numread <> 0) and (b <> 0) then result := result + '.';\r
 362       for a := start+numread+1 to start+numread+b do begin\r
 363         if (a >= len) then begin\r
 364           result := '';\r
 365           failurereason := 'decoding name: got out of range2';\r
 366           exit;\r
 367         end;\r
 368         result := result + ansichar(arr[a]);\r
 369       end;\r
 370       inc(numread,b+1);\r
 371 \r
 372       if b = 0 then begin\r
 373         if (result = '') and (recursion = 0) then result := '.';\r
 374         exit; {reached end of name}\r
 375       end;\r
 376     end else begin\r
 377       failurereason := 'decoding name: read invalid char';\r
 378       result := '';\r
 379       exit; {invalid}\r
 380     end;\r
 381   until false;\r
 382 end;\r
 383 \r
 384 {==============================================================================}\r
 385 \r
 386 function getrawfromrr(const rrp:trrpointer;len:integer):ansistring;\r
 387 begin\r
 388   setlength(result,htons(trr(rrp.p^).datalen));\r
 389   uniquestring(result);\r
 390   move(trr(rrp.p^).data,result[1],length(result));\r
 391 end;\r
 392 \r
 393 \r
 394 function getipfromrr(const rrp:trrpointer;len:integer):tbinip;\r
 395 begin\r
 396   fillchar(result,sizeof(result),0);\r
 397   case trr(rrp.p^).requesttype of\r
 398     querytype_a: begin\r
 399       if htons(trr(rrp.p^).datalen) <> 4 then exit;\r
 400       move(trr(rrp.p^).data,result.ip,4);\r
 401       result.family :=AF_INET;\r
 402     end;\r
 403     {$ifdef ipv6}\r
 404     querytype_aaaa: begin\r
 405       if htons(trr(rrp.p^).datalen) <> 16 then exit;\r
 406       result.family := AF_INET6;\r
 407       move(trr(rrp.p^).data,result.ip6,16);\r
 408     end;\r
 409     {$endif}\r
 410   else\r
 411     {}\r
 412   end;\r
 413 end;\r
 414 \r
 415 procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
 416 var\r
 417   a:integer;\r
 418 begin\r
 419   state.resultaction := action_done;\r
 420   state.resultstr := '';\r
 421   case trr(rrp.p^).requesttype of\r
 422     querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin\r
 423       state.resultbin := getipfromrr(rrp,len);\r
 424     end;\r
 425     querytype_txt:begin\r
 426       {TXT returns a raw string}\r
 427       state.resultstr := copy(getrawfromrr(rrp,len),2,9999);\r
 428       fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 429     end;\r
 430     querytype_mx:begin\r
 431       {MX is a name after a 16 bits word}\r
 432       state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);\r
 433       fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 434     end;\r
 435   else\r
 436     {other reply types (PTR, MX) return a hostname}\r
 437     state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);\r
 438     fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 439   end;\r
 440 end;\r
 441 \r
 442 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);\r
 443 begin\r
 444   {destroy things properly}\r
 445   state.resultstr := '';\r
 446   state.queryname := '';\r
 447   state.rrdata := '';\r
 448   fillchar(state,sizeof(state),0);\r
 449   state.queryname := name;\r
 450   state.parsepacket := false;\r
 451 end;\r
 452 \r
 453 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);\r
 454 begin\r
 455   setstate_request_init(name,state);\r
 456   state.forwardfamily := family;\r
 457   {$ifdef ipv6}\r
 458   if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
 459   {$endif}\r
 460   state.requesttype := querytype_a;\r
 461 end;\r
 462 \r
 463 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
 464 begin\r
 465   setstate_request_init(makereversename(binip),state);\r
 466   state.requesttype := querytype_ptr;\r
 467 end;\r
 468 \r
 469 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);\r
 470 begin\r
 471   setstate_request_init(name,state);\r
 472   state.requesttype := requesttype;\r
 473 end;\r
 474 \r
 475 \r
 476 procedure setstate_failure(var state:tdnsstate);\r
 477 begin\r
 478   state.resultstr := '';\r
 479   fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 480   state.resultaction := action_done;\r
 481 end;\r
 482 \r
 483 procedure state_process(var state:tdnsstate);\r
 484 label recursed;\r
 485 label failure;\r
 486 var\r
 487   a,b,ofs:integer;\r
 488   rrtemp:^trr;\r
 489   rrptemp:^trrpointer;\r
 490 begin\r
 491   if state.parsepacket then begin\r
 492     if state.recvpacketlen < 12 then begin\r
 493       failurereason := 'Undersized packet';\r
 494       state.resultaction := action_ignore;\r
 495       exit;\r
 496     end;\r
 497     if state.id <> state.recvpacket.id then begin\r
 498       failurereason := 'ID mismatch';\r
 499       state.resultaction := action_ignore;\r
 500       exit;\r
 501     end;\r
 502     state.numrr2 := 0;\r
 503     for a := 0 to 3 do begin\r
 504       state.numrr1[a] := htons(state.recvpacket.rrcount[a]);\r
 505       if state.numrr1[a] > maxrrofakind then goto failure;\r
 506       inc(state.numrr2,state.numrr1[a]);\r
 507     end;\r
 508 \r
 509     setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
 510 \r
 511     {- put all replies into a list}\r
 512 \r
 513     ofs := 12;\r
 514     {get all queries}\r
 515     for a := 0 to state.numrr1[0]-1 do begin\r
 516       if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;\r
 517       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 518       rrptemp.p := @state.recvpacket.payload[ofs-12];\r
 519       rrptemp.ofs := ofs;\r
 520       decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);\r
 521       rrptemp.len := b + 4;\r
 522       inc(ofs,rrptemp.len);\r
 523     end;\r
 524 \r
 525     for a := state.numrr1[0] to state.numrr2-1 do begin\r
 526       if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;\r
 527       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 528       if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;\r
 529       rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}\r
 530       rrptemp.p := rrtemp;\r
 531       rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}\r
 532       rrptemp.namelen := b;\r
 533       b := htons(rrtemp.datalen);\r
 534       rrptemp.len := b + 10 + rrptemp.namelen;\r
 535       inc(ofs,rrptemp.len);\r
 536     end;\r
 537     if (ofs <> state.recvpacketlen) then begin\r
 538       failurereason := 'ofs <> state.packetlen';\r
 539       goto failure;\r
 540     end;\r
 541 \r
 542     {if we requested A or AAAA build a list of all replies}\r
 543     if (state.requesttype = querytype_a) or (state.requesttype = querytype_aaaa) then begin\r
 544       state.resultlist := biniplist_new;\r
 545       for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 546         rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 547         rrtemp := rrptemp.p;\r
 548         b := rrptemp.len;\r
 549         if rrtemp.requesttype = state.requesttype then begin\r
 550           biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));\r
 551         end;\r
 552       end;\r
 553     end;\r
 554 \r
 555     {- check for items of the requested type in answer section, if so return success first}\r
 556     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 557       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 558       rrtemp := rrptemp.p;\r
 559       b := rrptemp.len;\r
 560       if rrtemp.requesttype = state.requesttype then begin\r
 561         setstate_return(rrptemp^,b,state);\r
 562         exit;\r
 563       end;\r
 564     end;\r
 565 \r
 566     {if no items of correct type found, follow first cname in answer section}\r
 567     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 568       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 569       rrtemp := rrptemp.p;\r
 570       b := rrptemp.len;\r
 571       if rrtemp.requesttype = querytype_cname then begin\r
 572         state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
 573         goto recursed;\r
 574       end;\r
 575     end;\r
 576 \r
 577     {no cnames found, no items of correct type found}\r
 578     if state.forwardfamily <> 0 then goto failure;\r
 579 \r
 580     goto failure;\r
 581 recursed:\r
 582     {here it needs recursed lookup}\r
 583     {if needing to follow a cname, change state to do so}\r
 584     inc(state.recursioncount);\r
 585     if state.recursioncount > maxrecursion then goto failure;\r
 586   end;\r
 587 \r
 588   {here, a name needs to be resolved}\r
 589   if state.queryname = '' then begin\r
 590     failurereason := 'empty query name';\r
 591     goto failure;\r
 592   end;\r
 593 \r
 594   {do /ets/hosts lookup here}\r
 595   state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);\r
 596   if state.sendpacketlen = 0 then begin\r
 597     failurereason := 'building request packet failed';\r
 598     goto failure;\r
 599   end;\r
 600   state.id := state.sendpacket.id;\r
 601   state.resultaction := action_sendquery;\r
 602 \r
 603   exit;\r
 604 failure:\r
 605   setstate_failure(state);\r
 606 end;\r
 607 \r
 608 \r
 609 procedure populatednsserverlist;\r
 610 var\r
 611   a:integer;\r
 612 begin\r
 613   if assigned(dnsserverlag) then begin\r
 614     dnsserverlag.clear;\r
 615   end else begin\r
 616     dnsserverlag := tlist.Create;\r
 617   end;\r
 618 \r
 619   dnsserverlist := getsystemdnsservers;\r
 620   for a := biniplist_getcount(dnsserverlist)-1 downto 0 do dnsserverlag.Add(nil);\r
 621 end;\r
 622 \r
 623 procedure cleardnsservercache;\r
 624 begin\r
 625   if assigned(dnsserverlag) then begin\r
 626     dnsserverlag.destroy;\r
 627     dnsserverlag := nil;\r
 628     dnsserverlist := '';\r
 629   end;\r
 630 end;\r
 631 \r
 632 function getcurrentsystemnameserverbin(var id:integer):tbinip;\r
 633 var\r
 634   counter : integer;\r
 635 begin\r
 636   {override the name server choice here, instead of overriding it whereever it's called\r
 637   setting ID to -1 causes it to be ignored in reportlag}\r
 638   if (overridednsserver <> '') then begin\r
 639     result := ipstrtobinf(overridednsserver);\r
 640     if result.family <> 0 then begin\r
 641       id := -1;\r
 642       exit;\r
 643     end;\r
 644   end;\r
 645 \r
 646   if not assigned(dnsserverlag) then populatednsserverlist;\r
 647   if dnsserverlag.count=0 then raise exception.create('no dns servers availible');\r
 648   id := 0;\r
 649   if dnsserverlag.count >1 then begin\r
 650     for counter := dnsserverlag.count-1 downto 1 do begin\r
 651       if taddrint(dnsserverlag[counter]) < taddrint(dnsserverlag[id]) then id := counter;\r
 652     end;\r
 653   end;\r
 654   result := biniplist_get(dnsserverlist,id);\r
 655 end;\r
 656 \r
 657 function getcurrentsystemnameserver(var id:integer):ansistring;\r
 658 begin\r
 659   result := ipbintostr(getcurrentsystemnameserverbin(id));\r
 660 end;\r
 661 \r
 662 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
 663 var\r
 664   counter : integer;\r
 665   temp : integer;\r
 666 begin\r
 667   if (id < 0) or (id >= dnsserverlag.count) then exit;\r
 668   if lag = -1 then lag := timeoutlag;\r
 669   for counter := 0 to dnsserverlag.count-1 do begin\r
 670     temp := taddrint(dnsserverlag[counter]) *15;\r
 671     if counter=id then temp := temp + lag;\r
 672     dnsserverlag[counter] := tobject(temp div 16);\r
 673   end;\r
 674 \r
 675 end;\r
 676 \r
 677 \r
 678 {$ifdef ipv6}\r
 679 \r
 680 procedure initpreferredmode;\r
 681 var\r
 682   l:tbiniplist;\r
 683   a:integer;\r
 684   ip:tbinip;\r
 685   ipmask_global,ipmask_6to4,ipmask_teredo:tbinip;\r
 686 \r
 687 begin\r
 688   if preferredmodeinited then exit;\r
 689   if useaf <> useaf_default then exit;\r
 690   l := getv6localips;\r
 691   if biniplist_getcount(l) = 0 then exit;\r
 692   useaf := useaf_preferv4;\r
 693   ipstrtobin('2000::',ipmask_global);\r
 694   ipstrtobin('2001::',ipmask_teredo);\r
 695   ipstrtobin('2002::',ipmask_6to4);\r
 696   {if there is any v6 IP which is globally routable and not 6to4 and not teredo, prefer v6}\r
 697   for a := biniplist_getcount(l)-1 downto 0 do begin\r
 698     ip := biniplist_get(l,a);\r
 699     if not comparebinipmask(ip,ipmask_global,3) then continue;\r
 700     if comparebinipmask(ip,ipmask_teredo,32) then continue;\r
 701     if comparebinipmask(ip,ipmask_6to4,16) then continue;\r
 702     useaf := useaf_preferv6;\r
 703     preferredmodeinited := true;\r
 704     exit;\r
 705   end;\r
 706 end;\r
 707 \r
 708 {$endif}\r
 709 \r
 710 \r
 711 {  quick and dirty description of dns packet structure to aid writing and\r
 712    understanding of parser code, refer to appropriate RFCs for proper specs\r
 713 - all words are network order\r
 714 \r
 715 www.google.com A request:\r
 716 \r
 717 0, 2: random transaction ID\r
 718 2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)\r
 719 4, 2: questions: 1\r
 720 6, 2: answer RR's: 0.\r
 721 8, 2: authority RR's: 0.\r
 722 10, 2: additional RR's: 0.\r
 723 12, n: payload:\r
 724   query:\r
 725     #03 "www" #06 "google" #03 "com" #00\r
 726     size-4, 2: type: host address (1)\r
 727     size-2, 2: class: inet (1)\r
 728 \r
 729 reply:\r
 730 \r
 731 0,2: random transaction ID\r
 732 2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
 733 4,4: questions: 1\r
 734 6,4: answer RR's: 2\r
 735 8,4: authority RR's: 9\r
 736 10,4: additional RR's: 9\r
 737 12: payload:\r
 738   query:\r
 739     ....\r
 740   answer: CNAME\r
 741     0,2 "c0 0c" "name: www.google.com"\r
 742     2,2 "00 05" "type: cname for an alias"\r
 743     4,2 "00 01" "class: inet"\r
 744     6,4: TTL\r
 745     10,2: data length "00 17" (23)\r
 746     12: the cname name (www.google.akadns.net)\r
 747   answer: A\r
 748     0,2 ..\r
 749     2,2 "00 01" host address\r
 750     4,2 ...\r
 751     6,4 ...\r
 752     10,2: data length (4)\r
 753     12,4: binary IP\r
 754   authority - 9 records\r
 755   additional - 9 records\r
 756 \r
 757 \r
 758   ipv6 AAAA reply:\r
 759     0,2: ...\r
 760     2,2: type: 001c\r
 761     4,2: class: inet (0001)\r
 762     6,2: TTL\r
 763     10,2: data size (16)\r
 764     12,16: binary IP\r
 765 \r
 766   ptr request: query type 000c\r
 767 \r
 768 name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
 769 \r
 770 end.\r