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