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