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 : tstringlist;\r
 192 //  currentdnsserverno : integer;\r
 193 \r
 194 \r
 195 //getcurrentsystemnameserver returns the nameserver the app should use and sets\r
 196 //id to the id of that nameserver. id should later be used to report how laggy\r
 197 //the servers response was and if it was timed out.\r
 198 function getcurrentsystemnameserver(var id:integer) :ansistring;\r
 199 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
 200 \r
 201 //var\r
 202 //  unixnameservercache:string;\r
 203 { $endif}\r
 204 \r
 205 \r
 206 {$ifdef ipv6}\r
 207 procedure initpreferredmode;\r
 208 \r
 209 var\r
 210   preferredmodeinited:boolean;\r
 211 \r
 212 {$endif}\r
 213 \r
 214 var\r
 215   failurereason:ansistring;\r
 216 \r
 217 function getquerytype(s:ansistring):integer;\r
 218 \r
 219 implementation\r
 220 \r
 221 uses\r
 222   {$ifdef win32}\r
 223     windows,\r
 224   {$endif}\r
 225   lcorelocalips,\r
 226   sysutils;\r
 227 \r
 228 \r
 229 \r
 230 function getquerytype(s:ansistring):integer;\r
 231 begin\r
 232   s := uppercase(s);\r
 233   result := 0;\r
 234   if (s = 'A') then result := querytype_a else\r
 235   if (s = 'CNAME') then result := querytype_cname else\r
 236   if (s = 'AAAA') then result := querytype_aaaa else\r
 237   if (s = 'PTR') then result := querytype_ptr else\r
 238   if (s = 'NS') then result := querytype_ns else\r
 239   if (s = 'MX') then result := querytype_mx else\r
 240   if (s = 'A6') then result := querytype_a6 else\r
 241   if (s = 'TXT') then result := querytype_txt else\r
 242   if (s = 'SOA') then result := querytype_soa else\r
 243   if (s = 'SPF') then result := querytype_spf;\r
 244 end;\r
 245 \r
 246 function buildrequest(const name:ansistring;var packet:tdnspacket;requesttype:word):integer;\r
 247 var\r
 248   a,b:integer;\r
 249   s:ansistring;\r
 250   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
 251 begin\r
 252  { writeln('buildrequest: name: ',name);}\r
 253   result := 0;\r
 254   fillchar(packet,sizeof(packet),0);\r
 255   packet.id := randominteger($10000);\r
 256 \r
 257   packet.flags := htons($0100);\r
 258   packet.rrcount[0] := htons($0001);\r
 259 \r
 260 \r
 261   s := copy(name,1,maxnamelength);\r
 262   if s = '' then exit;\r
 263   if s[length(s)] <> '.' then s := s + '.';\r
 264   b := 0;\r
 265   {encode name}\r
 266   if (s = '.') then begin\r
 267     packet.payload[0] := 0;\r
 268     result := 12+5;\r
 269   end else begin\r
 270     for a := 1 to length(s) do begin\r
 271       if s[a] = '.' then begin\r
 272         if b > maxnamefieldlen then exit;\r
 273         if (b = 0) then exit;\r
 274         packet.payload[a-b-1] := b;\r
 275         b := 0;\r
 276       end else begin\r
 277         packet.payload[a] := byte(s[a]);\r
 278         inc(b);\r
 279       end;\r
 280     end;\r
 281     if b > maxnamefieldlen then exit;\r
 282     packet.payload[length(s)-b] := b;\r
 283     result := length(s) + 12+5;\r
 284   end;\r
 285 \r
 286   arr[result-1] := 1;\r
 287   arr[result-3] := requesttype and $ff;\r
 288   arr[result-4] := requesttype shr 8;\r
 289 end;\r
 290 \r
 291 function makereversename(const binip:tbinip):ansistring;\r
 292 var\r
 293   name:ansistring;\r
 294   a,b:integer;\r
 295 begin\r
 296   name := '';\r
 297   if binip.family = AF_INET then begin\r
 298     b := htonl(binip.ip);\r
 299     for a := 0 to 3 do begin\r
 300       name := name + inttostr(b shr (a shl 3) and $ff)+'.';\r
 301     end;\r
 302     name := name + 'in-addr.arpa';\r
 303   end else\r
 304   {$ifdef ipv6}\r
 305   if binip.family = AF_INET6 then begin\r
 306     for a := 15 downto 0 do begin\r
 307       b := binip.ip6.u6_addr8[a];\r
 308       name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';\r
 309     end;\r
 310     name := name + 'ip6.arpa';\r
 311   end else\r
 312   {$endif}\r
 313   begin\r
 314     {empty name}\r
 315   end;\r
 316   result := name;\r
 317 end;\r
 318 \r
 319 {\r
 320 decodes DNS format name to a string. does not includes the root dot.\r
 321 doesnt read beyond len.\r
 322 empty result + non null failurereason: failure\r
 323 empty result + null failurereason: internal use\r
 324 }\r
 325 function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):ansistring;\r
 326 var\r
 327   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
 328   s:ansistring;\r
 329   a,b:integer;\r
 330 begin\r
 331   numread := 0;\r
 332   repeat\r
 333     if (start+numread < 0) or (start+numread >= len) then begin\r
 334       result := '';\r
 335       failurereason := 'decoding name: got out of range1';\r
 336       exit;\r
 337     end;\r
 338     b := arr[start+numread];\r
 339     if b >= $c0 then begin\r
 340       {recursive sub call}\r
 341       if recursion > 10 then begin\r
 342         result := '';\r
 343         failurereason := 'decoding name: max recursion';\r
 344         exit;\r
 345       end;\r
 346       if ((start+numread+1) >= len) then begin\r
 347         result := '';\r
 348         failurereason := 'decoding name: got out of range3';\r
 349         exit;\r
 350       end;\r
 351       a := ((b shl 8) or arr[start+numread+1]) and $3fff;\r
 352       s := decodename(packet,len,a,recursion+1,a);\r
 353       if (s = '') and (failurereason <> '') then begin\r
 354         result := '';\r
 355         exit;\r
 356       end;\r
 357       if result <> '' then result := result + '.';\r
 358       result := result + s;\r
 359       inc(numread,2);\r
 360       exit;\r
 361     end else if b < 64 then begin\r
 362       if (numread <> 0) and (b <> 0) then result := result + '.';\r
 363       for a := start+numread+1 to start+numread+b do begin\r
 364         if (a >= len) then begin\r
 365           result := '';\r
 366           failurereason := 'decoding name: got out of range2';\r
 367           exit;\r
 368         end;\r
 369         result := result + ansichar(arr[a]);\r
 370       end;\r
 371       inc(numread,b+1);\r
 372 \r
 373       if b = 0 then begin\r
 374         if (result = '') and (recursion = 0) then result := '.';\r
 375         exit; {reached end of name}\r
 376       end;\r
 377     end else begin\r
 378       failurereason := 'decoding name: read invalid char';\r
 379       result := '';\r
 380       exit; {invalid}\r
 381     end;\r
 382   until false;\r
 383 end;\r
 384 \r
 385 {==============================================================================}\r
 386 \r
 387 function getrawfromrr(const rrp:trrpointer;len:integer):ansistring;\r
 388 begin\r
 389   setlength(result,htons(trr(rrp.p^).datalen));\r
 390   uniquestring(result);\r
 391   move(trr(rrp.p^).data,result[1],length(result));\r
 392 end;\r
 393 \r
 394 \r
 395 function getipfromrr(const rrp:trrpointer;len:integer):tbinip;\r
 396 begin\r
 397   fillchar(result,sizeof(result),0);\r
 398   case trr(rrp.p^).requesttype of\r
 399     querytype_a: begin\r
 400       if htons(trr(rrp.p^).datalen) <> 4 then exit;\r
 401       move(trr(rrp.p^).data,result.ip,4);\r
 402       result.family :=AF_INET;\r
 403     end;\r
 404     {$ifdef ipv6}\r
 405     querytype_aaaa: begin\r
 406       if htons(trr(rrp.p^).datalen) <> 16 then exit;\r
 407       result.family := AF_INET6;\r
 408       move(trr(rrp.p^).data,result.ip6,16);\r
 409     end;\r
 410     {$endif}\r
 411   else\r
 412     {}\r
 413   end;\r
 414 end;\r
 415 \r
 416 procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
 417 var\r
 418   a:integer;\r
 419 begin\r
 420   state.resultaction := action_done;\r
 421   state.resultstr := '';\r
 422   case trr(rrp.p^).requesttype of\r
 423     querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin\r
 424       state.resultbin := getipfromrr(rrp,len);\r
 425     end;\r
 426     querytype_txt:begin\r
 427       {TXT returns a raw string}\r
 428       state.resultstr := copy(getrawfromrr(rrp,len),2,9999);\r
 429       fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 430     end;\r
 431     querytype_mx:begin\r
 432       {MX is a name after a 16 bits word}\r
 433       state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);\r
 434       fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 435     end;\r
 436   else\r
 437     {other reply types (PTR, MX) return a hostname}\r
 438     state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);\r
 439     fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 440   end;\r
 441 end;\r
 442 \r
 443 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);\r
 444 begin\r
 445   {destroy things properly}\r
 446   state.resultstr := '';\r
 447   state.queryname := '';\r
 448   state.rrdata := '';\r
 449   fillchar(state,sizeof(state),0);\r
 450   state.queryname := name;\r
 451   state.parsepacket := false;\r
 452 end;\r
 453 \r
 454 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);\r
 455 begin\r
 456   setstate_request_init(name,state);\r
 457   state.forwardfamily := family;\r
 458   {$ifdef ipv6}\r
 459   if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
 460   {$endif}\r
 461   state.requesttype := querytype_a;\r
 462 end;\r
 463 \r
 464 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
 465 begin\r
 466   setstate_request_init(makereversename(binip),state);\r
 467   state.requesttype := querytype_ptr;\r
 468 end;\r
 469 \r
 470 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);\r
 471 begin\r
 472   setstate_request_init(name,state);\r
 473   state.requesttype := requesttype;\r
 474 end;\r
 475 \r
 476 \r
 477 procedure setstate_failure(var state:tdnsstate);\r
 478 begin\r
 479   state.resultstr := '';\r
 480   fillchar(state.resultbin,sizeof(state.resultbin),0);\r
 481   state.resultaction := action_done;\r
 482 end;\r
 483 \r
 484 procedure state_process(var state:tdnsstate);\r
 485 label recursed;\r
 486 label failure;\r
 487 var\r
 488   a,b,ofs:integer;\r
 489   rrtemp:^trr;\r
 490   rrptemp:^trrpointer;\r
 491 begin\r
 492   if state.parsepacket then begin\r
 493     if state.recvpacketlen < 12 then begin\r
 494       failurereason := 'Undersized packet';\r
 495       state.resultaction := action_ignore;\r
 496       exit;\r
 497     end;\r
 498     if state.id <> state.recvpacket.id then begin\r
 499       failurereason := 'ID mismatch';\r
 500       state.resultaction := action_ignore;\r
 501       exit;\r
 502     end;\r
 503     state.numrr2 := 0;\r
 504     for a := 0 to 3 do begin\r
 505       state.numrr1[a] := htons(state.recvpacket.rrcount[a]);\r
 506       if state.numrr1[a] > maxrrofakind then goto failure;\r
 507       inc(state.numrr2,state.numrr1[a]);\r
 508     end;\r
 509 \r
 510     setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
 511 \r
 512     {- put all replies into a list}\r
 513 \r
 514     ofs := 12;\r
 515     {get all queries}\r
 516     for a := 0 to state.numrr1[0]-1 do begin\r
 517       if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;\r
 518       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 519       rrptemp.p := @state.recvpacket.payload[ofs-12];\r
 520       rrptemp.ofs := ofs;\r
 521       decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);\r
 522       rrptemp.len := b + 4;\r
 523       inc(ofs,rrptemp.len);\r
 524     end;\r
 525 \r
 526     for a := state.numrr1[0] to state.numrr2-1 do begin\r
 527       if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;\r
 528       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 529       if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;\r
 530       rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}\r
 531       rrptemp.p := rrtemp;\r
 532       rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}\r
 533       rrptemp.namelen := b;\r
 534       b := htons(rrtemp.datalen);\r
 535       rrptemp.len := b + 10 + rrptemp.namelen;\r
 536       inc(ofs,rrptemp.len);\r
 537     end;\r
 538     if (ofs <> state.recvpacketlen) then begin\r
 539       failurereason := 'ofs <> state.packetlen';\r
 540       goto failure;\r
 541     end;\r
 542 \r
 543     {if we requested A or AAAA build a list of all replies}\r
 544     if (state.requesttype = querytype_a) or (state.requesttype = querytype_aaaa) then begin\r
 545       state.resultlist := biniplist_new;\r
 546       for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 547         rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 548         rrtemp := rrptemp.p;\r
 549         b := rrptemp.len;\r
 550         if rrtemp.requesttype = state.requesttype then begin\r
 551           biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));\r
 552         end;\r
 553       end;\r
 554     end;\r
 555 \r
 556     {- check for items of the requested type in answer section, if so return success first}\r
 557     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 558       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 559       rrtemp := rrptemp.p;\r
 560       b := rrptemp.len;\r
 561       if rrtemp.requesttype = state.requesttype then begin\r
 562         setstate_return(rrptemp^,b,state);\r
 563         exit;\r
 564       end;\r
 565     end;\r
 566 \r
 567     {if no items of correct type found, follow first cname in answer section}\r
 568     for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin\r
 569       rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];\r
 570       rrtemp := rrptemp.p;\r
 571       b := rrptemp.len;\r
 572       if rrtemp.requesttype = querytype_cname then begin\r
 573         state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
 574         goto recursed;\r
 575       end;\r
 576     end;\r
 577 \r
 578     {no cnames found, no items of correct type found}\r
 579     if state.forwardfamily <> 0 then goto failure;\r
 580 \r
 581     goto failure;\r
 582 recursed:\r
 583     {here it needs recursed lookup}\r
 584     {if needing to follow a cname, change state to do so}\r
 585     inc(state.recursioncount);\r
 586     if state.recursioncount > maxrecursion then goto failure;\r
 587   end;\r
 588 \r
 589   {here, a name needs to be resolved}\r
 590   if state.queryname = '' then begin\r
 591     failurereason := 'empty query name';\r
 592     goto failure;\r
 593   end;\r
 594 \r
 595   {do /ets/hosts lookup here}\r
 596   state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);\r
 597   if state.sendpacketlen = 0 then begin\r
 598     failurereason := 'building request packet failed';\r
 599     goto failure;\r
 600   end;\r
 601   state.id := state.sendpacket.id;\r
 602   state.resultaction := action_sendquery;\r
 603 \r
 604   exit;\r
 605 failure:\r
 606   setstate_failure(state);\r
 607 end;\r
 608 {$ifdef win32}\r
 609   const\r
 610     MAX_HOSTNAME_LEN = 132;\r
 611     MAX_DOMAIN_NAME_LEN = 132;\r
 612     MAX_SCOPE_ID_LEN = 260    ;\r
 613     MAX_ADAPTER_NAME_LENGTH = 260;\r
 614     MAX_ADAPTER_ADDRESS_LENGTH = 8;\r
 615     MAX_ADAPTER_DESCRIPTION_LENGTH = 132;\r
 616     ERROR_BUFFER_OVERFLOW = 111;\r
 617     MIB_IF_TYPE_ETHERNET = 6;\r
 618     MIB_IF_TYPE_TOKENRING = 9;\r
 619     MIB_IF_TYPE_FDDI = 15;\r
 620     MIB_IF_TYPE_PPP = 23;\r
 621     MIB_IF_TYPE_LOOPBACK = 24;\r
 622     MIB_IF_TYPE_SLIP = 28;\r
 623 \r
 624 \r
 625   type\r
 626     tip_addr_string=packed record\r
 627       Next :pointer;\r
 628       IpAddress : array[0..15] of ansichar;\r
 629       ipmask    : array[0..15] of ansichar;\r
 630       context   : dword;\r
 631     end;\r
 632     pip_addr_string=^tip_addr_string;\r
 633     tFIXED_INFO=packed record\r
 634        HostName         : array[0..MAX_HOSTNAME_LEN-1] of ansichar;\r
 635        DomainName       : array[0..MAX_DOMAIN_NAME_LEN-1] of ansichar;\r
 636        currentdnsserver : pip_addr_string;\r
 637        dnsserverlist    : tip_addr_string;\r
 638        nodetype         : longint;\r
 639        ScopeId          : array[0..MAX_SCOPE_ID_LEN + 4] of ansichar;\r
 640        enablerouting    : longbool;\r
 641        enableproxy      : longbool;\r
 642        enabledns        : longbool;\r
 643     end;\r
 644     pFIXED_INFO=^tFIXED_INFO;\r
 645 \r
 646   var\r
 647     iphlpapi : thandle;\r
 648     getnetworkparams : function(pFixedInfo : PFIXED_INFO;OutBufLen : plongint) : longint;stdcall;\r
 649 {$endif}\r
 650 procedure populatednsserverlist;\r
 651 var\r
 652   {$ifdef win32}\r
 653     fixed_info : pfixed_info;\r
 654     fixed_info_len : longint;\r
 655     currentdnsserver : pip_addr_string;\r
 656   {$else}\r
 657     t:textfile;\r
 658     s:ansistring;\r
 659     a:integer;\r
 660   {$endif}\r
 661 begin\r
 662   //result := '';\r
 663   if assigned(dnsserverlist) then begin\r
 664     dnsserverlist.clear;\r
 665   end else begin\r
 666     dnsserverlist := tstringlist.Create;\r
 667   end;\r
 668   {$ifdef win32}\r
 669     if iphlpapi=0 then iphlpapi := loadlibrary('iphlpapi.dll');\r
 670     if not assigned(getnetworkparams) then @getnetworkparams := getprocaddress(iphlpapi,'GetNetworkParams');\r
 671     if not assigned(getnetworkparams) then exit;\r
 672     fixed_info_len := 0;\r
 673     if GetNetworkParams(nil,@fixed_info_len)<>ERROR_BUFFER_OVERFLOW then exit;\r
 674     //fixed_info_len :=sizeof(tfixed_info);\r
 675     getmem(fixed_info,fixed_info_len);\r
 676     if GetNetworkParams(fixed_info,@fixed_info_len)<>0 then begin\r
 677       freemem(fixed_info);\r
 678       exit;\r
 679     end;\r
 680     currentdnsserver := @(fixed_info.dnsserverlist);\r
 681     while assigned(currentdnsserver) do begin\r
 682       dnsserverlist.Add(currentdnsserver.IpAddress);\r
 683       currentdnsserver := currentdnsserver.next;\r
 684     end;\r
 685     freemem(fixed_info);\r
 686   {$else}\r
 687     filemode := 0;\r
 688     assignfile(t,'/etc/resolv.conf');\r
 689     {$i-}reset(t);{$i+}\r
 690     if ioresult <> 0 then exit;\r
 691 \r
 692     while not eof(t) do begin\r
 693       readln(t,s);\r
 694       if not (copy(s,1,10) = 'nameserver') then continue;\r
 695       s := copy(s,11,500);\r
 696       while s <> '' do begin\r
 697         if (s[1] = #32) or (s[1] = #9) then s := copy(s,2,500) else break;\r
 698       end;\r
 699       a := pos(' ',s);\r
 700       if a <> 0 then s := copy(s,1,a-1);\r
 701       a := pos(#9,s);\r
 702       if a <> 0 then s := copy(s,1,a-1);\r
 703       //result := s;\r
 704       //if result <> '' then break;\r
 705       dnsserverlist.Add(s);\r
 706     end;\r
 707     close(t);\r
 708   {$endif}\r
 709 end;\r
 710 \r
 711 procedure cleardnsservercache;\r
 712 begin\r
 713   if assigned(dnsserverlist) then begin\r
 714     dnsserverlist.destroy;\r
 715     dnsserverlist := nil;\r
 716   end;\r
 717 end;\r
 718 \r
 719 function getcurrentsystemnameserver(var id:integer):ansistring;\r
 720 var\r
 721   counter : integer;\r
 722 \r
 723 begin\r
 724   if not assigned(dnsserverlist) then populatednsserverlist;\r
 725   if dnsserverlist.count=0 then raise exception.create('no dns servers availible');\r
 726   id := 0;\r
 727   if dnsserverlist.count >1 then begin\r
 728 \r
 729     for counter := 1 to dnsserverlist.count-1 do begin\r
 730       if taddrint(dnsserverlist.objects[counter]) < taddrint(dnsserverlist.objects[id]) then id := counter;\r
 731     end;\r
 732   end;\r
 733   result := dnsserverlist[id]\r
 734 end;\r
 735 \r
 736 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
 737 var\r
 738   counter : integer;\r
 739   temp : integer;\r
 740 begin\r
 741   if (id < 0) or (id >= dnsserverlist.count) then exit;\r
 742   if lag = -1 then lag := timeoutlag;\r
 743   for counter := 0 to dnsserverlist.count-1 do begin\r
 744     temp := taddrint(dnsserverlist.objects[counter]) *15;\r
 745     if counter=id then temp := temp + lag;\r
 746     dnsserverlist.objects[counter] := tobject(temp div 16);\r
 747   end;\r
 748 \r
 749 end;\r
 750 \r
 751 \r
 752 {$ifdef ipv6}\r
 753 \r
 754 procedure initpreferredmode;\r
 755 var\r
 756   l:tbiniplist;\r
 757   a:integer;\r
 758   ip:tbinip;\r
 759   ipmask_global,ipmask_6to4,ipmask_teredo:tbinip;\r
 760 \r
 761 begin\r
 762   if preferredmodeinited then exit;\r
 763   if useaf <> useaf_default then exit;\r
 764   l := getv6localips;\r
 765   if biniplist_getcount(l) = 0 then exit;\r
 766   useaf := useaf_preferv4;\r
 767   ipstrtobin('2000::',ipmask_global);\r
 768   ipstrtobin('2001::',ipmask_teredo);\r
 769   ipstrtobin('2002::',ipmask_6to4);\r
 770   {if there is any v6 IP which is globally routable and not 6to4 and not teredo, prefer v6}\r
 771   for a := biniplist_getcount(l)-1 downto 0 do begin\r
 772     ip := biniplist_get(l,a);\r
 773     if not comparebinipmask(ip,ipmask_global,3) then continue;\r
 774     if comparebinipmask(ip,ipmask_teredo,32) then continue;\r
 775     if comparebinipmask(ip,ipmask_6to4,16) then continue;\r
 776     useaf := useaf_preferv6;\r
 777     preferredmodeinited := true;\r
 778     exit;\r
 779   end;\r
 780 end;\r
 781 \r
 782 {$endif}\r
 783 \r
 784 \r
 785 {  quick and dirty description of dns packet structure to aid writing and\r
 786    understanding of parser code, refer to appropriate RFCs for proper specs\r
 787 - all words are network order\r
 788 \r
 789 www.google.com A request:\r
 790 \r
 791 0, 2: random transaction ID\r
 792 2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)\r
 793 4, 2: questions: 1\r
 794 6, 2: answer RR's: 0.\r
 795 8, 2: authority RR's: 0.\r
 796 10, 2: additional RR's: 0.\r
 797 12, n: payload:\r
 798   query:\r
 799     #03 "www" #06 "google" #03 "com" #00\r
 800     size-4, 2: type: host address (1)\r
 801     size-2, 2: class: inet (1)\r
 802 \r
 803 reply:\r
 804 \r
 805 0,2: random transaction ID\r
 806 2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
 807 4,4: questions: 1\r
 808 6,4: answer RR's: 2\r
 809 8,4: authority RR's: 9\r
 810 10,4: additional RR's: 9\r
 811 12: payload:\r
 812   query:\r
 813     ....\r
 814   answer: CNAME\r
 815     0,2 "c0 0c" "name: www.google.com"\r
 816     2,2 "00 05" "type: cname for an alias"\r
 817     4,2 "00 01" "class: inet"\r
 818     6,4: TTL\r
 819     10,2: data length "00 17" (23)\r
 820     12: the cname name (www.google.akadns.net)\r
 821   answer: A\r
 822     0,2 ..\r
 823     2,2 "00 01" host address\r
 824     4,2 ...\r
 825     6,4 ...\r
 826     10,2: data length (4)\r
 827     12,4: binary IP\r
 828   authority - 9 records\r
 829   additional - 9 records\r
 830 \r
 831 \r
 832   ipv6 AAAA reply:\r
 833     0,2: ...\r
 834     2,2: type: 001c\r
 835     4,2: class: inet (0001)\r
 836     6,2: TTL\r
 837     10,2: data size (16)\r
 838     12,16: binary IP\r
 839 \r
 840   ptr request: query type 000c\r
 841 \r
 842 name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
 843 \r
 844 end.\r