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