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
8 code wanting to use this dns system should act as follows (note: app
\r
9 developers will probably want to use dnsasync or dnssync or write a similar
\r
10 wrapper unit of their own).
\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 relevant state manually.
\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
23 action_done means the request has completed (either succeeded or failed)
\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
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
31 once the app gets action_done it can determine success or failure in the
\r
34 on failure state.resultstr will be an empty string and state.resultbin will
\r
35 be zeroed out (easily detected by the fact that it will have a family of 0)
\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
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 prefers IPv6 but wants IPv4 results as well it must
\r
44 check them separately.
\r
46 on success for any other type of lookup state.resultstr will be an empty
\r
48 note the state contains ansistrings, setstate_init with a null name parameter
\r
49 can be used to clean these up if required.
\r
51 callers may use setstate_failure to mark the state as failed themselves
\r
52 before passing it on to other code, for example this may be done in the event
\r
58 code is here to do hosts file lookups. this is not done automatically by
\r
59 dnscore, the caller (this is dnssync and dnsasync) has to call the hosts file
\r
60 functions if it wants hosts file lookups.
\r
62 the current implementation will automatically periodically reload the file into
\r
63 a fast lookup cache if the file changed.
\r
65 both forward and reverse lookups are supported.
\r
67 a single IP having multiple hostnames, so "192.0.2.1 foo bar" is supported.
\r
69 local hostnames under the locally configured domain (so domain "example.org",
\r
70 a "192.0.2.1 foo" entry causing "foo.example.org" to resolve) is not supported.
\r
74 {$ifdef fpc}{$mode delphi}{$endif}
\r
76 {$include lcoreconfig.inc}
\r
80 uses binipstuff,classes,pgtypes,lcorernd;
\r
82 var usewindns : boolean = {$ifdef mswindows}true{$else}false{$endif};
\r
83 {hint to users of this unit that they should use windows dns instead.
\r
84 May be disabled by applications if desired. (e.g. if setting a custom
\r
87 note: this unit will not be able to self populate it's dns server list on
\r
88 older versions of windows.}
\r
97 hint to users of this unit to how to deal with connecting to hostnames regarding ipv4 or ipv6 usage
\r
98 can be set by apps as desired
\r
100 var useaf:integer = useaf_default;
\r
103 (temporarily) use a different nameserver, regardless of the dnsserverlist
\r
105 var overridednsserver:ansistring;
\r
109 maxnamefieldlen=63;
\r
110 //note: when using action_ignore the dnscore code *must* preserve the contents of state.sendpacket to allow for retries
\r
111 //note: action_ignore must not be used in response to the original request but there is no valid reason for doing this anyway
\r
114 action_sendquery=2;
\r
127 {the maximum number of RR of a kind of purely an extra sanity check and could be omitted.
\r
128 before, i set it to 20, but valid replies can have more. dnscore only does udp requests,
\r
129 and ordinary DNS, so up to 512 bytes. the maximum number of A records that fits seems to be 29}
\r
131 retryafter=300000; //microseconds must be less than one second;
\r
132 timeoutlag=1000000000; // penalty value to be treated as lag in the event of a timeout (microseconds)
\r
134 dvar=array[0..0] of byte;
\r
136 tdnspacket=packed record
\r
139 rrcount:array[0..3] of word;
\r
140 payload:array[0..511-12] of byte;
\r
147 recursioncount:integer;
\r
148 queryname:ansistring;
\r
150 parsepacket:boolean;
\r
151 resultstr:ansistring;
\r
153 resultlist:tbiniplist;
\r
154 resultaction:integer;
\r
155 numrr1:array[0..3] of integer;
\r
158 sendpacketlen:integer;
\r
159 sendpacket:tdnspacket;
\r
160 recvpacketlen:integer;
\r
161 recvpacket:tdnspacket;
\r
162 forwardfamily:integer;
\r
166 requesttypehi:byte;
\r
171 data:array[0..511] of byte;
\r
174 trrpointer=packed record
\r
181 //commenting out functions from interface that do not have documented semantics
\r
182 //and probably should not be called from outside this unit, reenable them
\r
183 //if you must but please document them at the same time --plugwash
\r
185 //function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;
\r
187 //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
188 function makereversename(const binip:tbinip):ansistring;
\r
190 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);
\r
192 //set up state for a forward lookup. A family value of AF_INET6 will give only
\r
193 //ipv6 results. Any other value will give only ipv4 results
\r
194 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);
\r
196 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
\r
197 procedure setstate_failure(var state:tdnsstate);
\r
198 //procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
\r
200 //for custom raw lookups such as TXT, as desired by the user
\r
201 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);
\r
203 procedure state_process(var state:tdnsstate);
\r
205 //function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;
\r
207 procedure populatednsserverlist;
\r
208 procedure cleardnsservercache;
\r
211 dnsserverlist : tbiniplist;
\r
212 dnsserverlag:tlist;
\r
213 // currentdnsserverno : integer;
\r
216 //getcurrentsystemnameserver returns the nameserver the app should use and sets
\r
217 //id to the id of that nameserver. id should later be used to report how laggy
\r
218 //the servers response was and if it was timed out.
\r
219 function getcurrentsystemnameserver(var id:integer) :ansistring;
\r
220 function getcurrentsystemnameserverbin(var id:integer) :tbinip;
\r
221 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
\r
224 // unixnameservercache:string;
\r
229 procedure initpreferredmode;
\r
232 preferredmodeinited:boolean;
\r
237 failurereason:ansistring;
\r
239 function getquerytype(s:ansistring):integer;
\r
241 //optionally do any time consuming initing in advance, in case one wants the first dns lookup to be as fast as possible
\r
242 procedure dnscore_preinit(alsoreverse:boolean);
\r
245 hostsfile_inited:boolean;
\r
246 hostsfile_reverseinited:boolean;
\r
247 hostsfile_filename:ansistring; //the app can change this, to use a custom hosts file
\r
248 hostsfile_entries:tstringlist;
\r
249 hostsfile_lastfileage:longint; //fileage is longint on freepascal, integer on delphi
\r
250 hostsfile_lastcheckts:integer;
\r
251 hostsfile_reverseentries:tstringlist;
\r
253 //parameter settings
\r
254 hostsfile_disabled:boolean; //the app can set this to disable all hosts file lookup functionality, including localhost
\r
255 hostsfile_onlylocalhost:boolean; //the app can set this to disable the hosts file but keep localhost
\r
256 hostsfile_alsocustomserver:boolean; //the app can set this to use hosts file functionality even when a custom nameserver is set
\r
257 hostsfile_manualreload:boolean; //don't check if the hosts file changed and auto reload it, the app can call hostsfile_reload to reload
\r
259 procedure hostsfile_init;
\r
260 procedure hostsfile_initreverse;
\r
261 procedure hostsfile_reload;
\r
262 procedure hostsfile_reloadifneeded;
\r
263 procedure hostsfile_add(const name:ansistring;const ip:tbinip);
\r
264 function hostsfile_forwardlookuplist(const name:ansistring):tbiniplist;
\r
265 function hostsfile_reverselookup(ip:tbinip):ansistring;
\r
266 function gethostsfilename:ansistring;
\r
271 {$ifdef mswindows}windows,{$endif}
\r
272 {$ifdef unix}unix,{$endif}
\r
279 pbiniplist=^tbiniplist;
\r
280 thostsfile_entry=record
\r
283 phostsfile_entry=^thostsfile_entry;
\r
285 thostsfile_reverseentry=record
\r
288 phostsfile_reverseentry=^thostsfile_reverseentry;
\r
291 function hostsfile_findbyname(const name:ansistring):integer;
\r
293 if not hostsfile_entries.Find(name,result) then begin
\r
294 if (copy(name,length(name),1) = '.') then begin
\r
295 //if the name has a trailing dot, try to find without it
\r
296 if not hostsfile_entries.Find(copy(name,1,length(name)-1),result) then result := -1;
\r
298 //if the name has no trailing dot, try to find with it
\r
299 if not hostsfile_entries.Find(name + '.',result) then result := -1;
\r
305 function hostsfile_forwardlookuplist(const name:ansistring):tbiniplist;
\r
311 index := hostsfile_findbyname(name);
\r
313 result := biniplist_new;
\r
315 if (index >= 0) then begin
\r
316 l := phostsfile_entry(hostsfile_entries.objects[index]).l;
\r
319 if (useaf <> useaf_v6) and (useaf <> useaf_preferv6) then
\r
322 addipsoffamily(result,l,af_inet);
\r
325 if (useaf <> useaf_v4) then begin
\r
326 addipsoffamily(result,l,af_inet6);
\r
327 if (useaf = useaf_preferv6) then begin
\r
328 addipsoffamily(result,l,af_inet);
\r
335 procedure hostsfile_clearreverse;
\r
339 for index := hostsfile_reverseentries.count-1 downto 0 do begin
\r
340 phostsfile_reverseentry(hostsfile_reverseentries.objects[index]).name := '';
\r
341 dispose(phostsfile_reverseentry(hostsfile_reverseentries.objects[index]));
\r
343 hostsfile_reverseentries.clear;
\r
347 procedure hostsfile_initreverse;
\r
349 index,index2:integer;
\r
351 a,countbefore:integer;
\r
354 he:phostsfile_reverseentry;
\r
357 if hostsfile_reverseinited then exit;
\r
358 hostsfile_reverseinited := true;
\r
360 hostsfile_clearreverse;
\r
362 //build fast search table for reverse lookups
\r
363 for index := hostsfile_entries.count-1 downto 0 do begin
\r
364 l := phostsfile_entry(hostsfile_entries.objects[index]).l;
\r
365 for a := biniplist_getcount(l)-1 downto 0 do begin
\r
366 ip := biniplist_get(l,a);
\r
367 s := ipbintostr(ip);
\r
369 countbefore := hostsfile_reverseentries.count;
\r
370 index2 := hostsfile_reverseentries.Add(s);
\r
371 if (hostsfile_reverseentries.count > countbefore) then begin
\r
373 hostsfile_reverseentries.objects[index2] := tobject(he);
\r
374 he.name := hostsfile_entries[index];
\r
381 function hostsfile_reverselookup(ip:tbinip):ansistring;
\r
386 hostsfile_initreverse;
\r
388 s := ipbintostr(ip);
\r
390 if hostsfile_reverseentries.find(s,index) then begin
\r
391 result := phostsfile_reverseentry(hostsfile_reverseentries.objects[index]).name;
\r
395 procedure hostsfile_clear;
\r
399 for index := hostsfile_entries.count-1 downto 0 do begin
\r
400 biniplist_free(phostsfile_entry(hostsfile_entries.objects[index]).l);
\r
401 dispose(phostsfile_entry(hostsfile_entries.objects[index]));
\r
403 hostsfile_entries.clear;
\r
405 hostsfile_clearreverse;
\r
407 hostsfile_lastfileage := 0;
\r
408 hostsfile_lastcheckts := 0;
\r
411 procedure hostsfile_add(const name:ansistring;const ip:tbinip);
\r
414 a,index,countbefore:integer;
\r
417 he:phostsfile_entry;
\r
421 countbefore := hostsfile_entries.count;
\r
422 //add, with dupignore, will add it if it's not in the list. if it is in the list, it returns the index
\r
423 //to know if it was added, see if the count went up. this saves on duplicate searches in the list, for speed
\r
424 index := hostsfile_entries.add(name);
\r
426 if (hostsfile_entries.count > countbefore) then begin
\r
427 // writeln('name newly added ',name,' ',ipbintostr(ip),' ',index);
\r
430 hostsfile_entries.objects[index] := tobject(he);
\r
431 he.l := biniplist_new;
\r
434 // writeln('name found ',name,' ',ipbintostr(ip),' ',index);
\r
435 //search for IP match
\r
437 he := phostsfile_entry(hostsfile_entries.objects[index]);
\r
439 for a := biniplist_getcount(l)-1 downto 0 do begin
\r
440 ip2 := biniplist_get(l,a);
\r
441 if comparebinip(ip,ip2) then begin
\r
442 // writeln('duplicate ip ',name,' ',ipbintostr(ip));
\r
448 biniplist_add(he.l,ip);
\r
452 function getts:integer;
\r
455 result := GetTickCount;
\r
460 gettimemonotonic(temp);
\r
461 result := ((temp.tv_usec div 1000) + (temp.tv_sec * 1000));
\r
466 function gethostsfilename:ansistring;
\r
469 windir:array [0..255] of ansichar;
\r
471 GetSystemWindowsDirectoryA:function(buffer:pansichar;size:integer):integer; stdcall;
\r
473 OsVersion : TOSVersionInfo;
\r
475 filenamesuffix:ansistring;
\r
479 ZeroMemory(@OsVersion, SizeOf(OsVersion));
\r
480 OsVersion.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);
\r
482 if ((GetVersionEx(OsVersion)) and (OsVersion.dwPlatformId = VER_PLATFORM_WIN32_NT)) then begin
\r
483 filenamesuffix := '\system32\drivers\etc\hosts';
\r
485 filenamesuffix := '\hosts';
\r
488 //first try "user" windows directory. on a multiuser this may not be c:\windows
\r
489 GetWindowsDirectoryA(windir,255);
\r
491 if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);
\r
492 result := result + filenamesuffix;
\r
494 if not fileexists(result) then begin
\r
495 //then try "system" windows directory which is typically c:\windows on a multiuser system
\r
496 dllhandle := loadlibrary('kernel32.dll');
\r
497 if (dllhandle <> 0) then begin
\r
498 GetSystemWindowsDirectoryA := getprocaddress(dllhandle,'GetSystemWindowsDirectoryA');
\r
499 if assigned(GetSystemWindowsDirectoryA) then begin
\r
500 GetSystemWindowsDirectoryA(windir,255);
\r
501 freelibrary(dllhandle);
\r
503 if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);
\r
504 result := result + filenamesuffix;
\r
510 result := '/etc/hosts';
\r
514 procedure hostsfile_reload;
\r
519 validchar:array[0..255] of boolean;
\r
520 ipv4char:array[0..255] of boolean;
\r
523 a,len,field,startindex,labellen:integer;
\r
524 lastwasspace,onlyipv4chars:boolean;
\r
525 ipstring,hostname:ansistring;
\r
530 if hostsfile_disabled then exit;
\r
531 hostsfile_reverseinited := false;
\r
533 //add builtin entries
\r
534 hostsfile_add('localhost',ipstrtobinf('127.0.0.1'));
\r
536 hostsfile_add('localhost',ipstrtobinf('::1'));
\r
539 if hostsfile_onlylocalhost then exit;
\r
541 if (hostsfile_filename = '') then hostsfile_filename := gethostsfilename;
\r
543 //DNS names can only contain lower and uppercase, digits, dash, and dot
\r
544 fillchar(validchar,sizeof(validchar),0);
\r
545 validchar[ord('.')] := true;
\r
546 validchar[ord('-')] := true;
\r
547 fillchar(validchar[48],10,1);
\r
548 fillchar(validchar[65],26,1);
\r
549 fillchar(validchar[97],26,1);
\r
551 //chars that can be in an ipv4 address: digits and dot
\r
552 fillchar(ipv4char,sizeof(ipv4char),0);
\r
553 ipv4char[ord('.')] := true;
\r
554 fillchar(ipv4char[48],10,1);
\r
556 hostsfile_lastfileage := fileage(hostsfile_filename);
\r
557 hostsfile_lastcheckts := getts;
\r
558 //writeln('------ reloading ',hostsfile_lastfileage);
\r
560 t := treadtxt.createf(hostsfile_filename);
\r
564 if not assigned(t) then exit;
\r
566 while not t.eof do begin
\r
570 if (len > 512) then goto lineend; //sanity check
\r
572 lastwasspace := true;
\r
574 onlyipv4chars := true;
\r
576 //one extra loop iteration at the end with a "pretend space" for easy parsing
\r
581 while (a <= len) do begin
\r
583 if (a >= len) then ch := ' ' else ch := s[a];
\r
585 if (ch = '#') then begin
\r
586 //pretend the start of a comment is a space and the end of the line
\r
591 if (ch = #9) or (ch = ' ') then begin
\r
592 if not (lastwasspace) then begin
\r
593 if (field = 0) then begin
\r
594 ipstring := copy(s,startindex,a - startindex);
\r
595 end else if (field >= 1) then begin
\r
596 //maximum length of hostname
\r
597 if (a - startindex) > 253 then goto lineend;
\r
599 //remove a trailing dot
\r
600 //if (labellen = 0) then dec(a);
\r
602 //hostname must not be an empty string
\r
603 if (a - startindex) < 1 then goto lineend;
\r
605 hostname := copy(s,startindex,a - startindex);
\r
607 //reject a hosts entry with a name that is a valid ipv4 address.
\r
608 //we don't need to check for ipv6 addresses because they have a colon and so aren't valid hostsnames
\r
609 //the windows resolver does allow it, but i think it has potential security issues
\r
610 if onlyipv4chars then if ipstrtobin(hostname,biniptemp) then goto lineend;
\r
612 if ipstrtobin(ipstring,biniptemp) then begin
\r
613 //writeln('!!!hosts file adding ip=',ipstring,'@host=',hostname,'@');
\r
615 hostsfile_add(hostname,biniptemp);
\r
624 lastwasspace := true;
\r
626 if lastwasspace then begin
\r
629 lastwasspace := false;
\r
632 //enforce valid characters in hostname
\r
633 if (field = 1) then begin
\r
634 if not validchar[ord(ch)] then goto lineend;
\r
635 onlyipv4chars := onlyipv4chars and ipv4char[ord(ch)];
\r
636 if (ch = '.') then begin
\r
637 if (labellen = 0) then goto lineend;
\r
641 if (labellen > 63) then goto lineend;
\r
653 procedure hostsfile_reloadifneeded;
\r
657 if (hostsfile_disabled or hostsfile_onlylocalhost or hostsfile_manualreload) then exit;
\r
658 if hostsfile_filename = '' then exit;
\r
661 //writeln('reloadifneeded ts=',ts,' oldts=',hostsfile_lastcheckts);
\r
662 if not ((ts > hostsfile_lastcheckts + 10000) or (ts < hostsfile_lastcheckts)) then exit;
\r
664 hostsfile_lastcheckts := ts;
\r
666 //writeln('reloadifneeded new=',fileage(hostsfile_filename),' old=',hostsfile_lastfileage);
\r
667 if fileage(hostsfile_filename) = hostsfile_lastfileage then exit;
\r
671 procedure hostsfile_init;
\r
673 //writeln('init ',hostsfile_inited);
\r
674 if hostsfile_inited then begin
\r
675 hostsfile_reloadifneeded;
\r
678 hostsfile_inited := true;
\r
679 hostsfile_entries := tstringlist.create;
\r
680 hostsfile_entries.casesensitive := false;
\r
681 hostsfile_entries.sorted := true;
\r
682 hostsfile_entries.duplicates := dupignore;
\r
684 hostsfile_reverseentries := tstringlist.create;
\r
685 hostsfile_reverseentries.casesensitive := true;
\r
686 hostsfile_reverseentries.sorted := true;
\r
687 hostsfile_reverseentries.duplicates := dupignore;
\r
692 procedure dnscore_preinit(alsoreverse:boolean);
\r
698 populatednsserverlist;
\r
700 if alsoreverse then hostsfile_initreverse;
\r
704 function getquerytype(s:ansistring):integer;
\r
708 if (s = 'A') then result := querytype_a else
\r
709 if (s = 'CNAME') then result := querytype_cname else
\r
710 if (s = 'AAAA') then result := querytype_aaaa else
\r
711 if (s = 'PTR') then result := querytype_ptr else
\r
712 if (s = 'NS') then result := querytype_ns else
\r
713 if (s = 'MX') then result := querytype_mx else
\r
714 if (s = 'A6') then result := querytype_a6 else
\r
715 if (s = 'TXT') then result := querytype_txt else
\r
716 if (s = 'SOA') then result := querytype_soa else
\r
717 if (s = 'SPF') then result := querytype_spf;
\r
720 function buildrequest(const name:ansistring;var packet:tdnspacket;requesttype:word):integer;
\r
724 arr:array[0..sizeof(packet)-1] of byte absolute packet;
\r
726 { writeln('buildrequest: name: ',name);}
\r
728 fillchar(packet,sizeof(packet),0);
\r
729 packet.id := randominteger($10000);
\r
731 packet.flags := htons($0100);
\r
732 packet.rrcount[0] := htons($0001);
\r
735 s := copy(name,1,maxnamelength);
\r
736 if s = '' then exit;
\r
737 if s[length(s)] <> '.' then s := s + '.';
\r
740 if (s = '.') then begin
\r
741 packet.payload[0] := 0;
\r
744 for a := 1 to length(s) do begin
\r
745 if s[a] = '.' then begin
\r
746 if b > maxnamefieldlen then exit;
\r
747 if (b = 0) then exit;
\r
748 packet.payload[a-b-1] := b;
\r
751 packet.payload[a] := byte(s[a]);
\r
755 if b > maxnamefieldlen then exit;
\r
756 packet.payload[length(s)-b] := b;
\r
757 result := length(s) + 12+5;
\r
760 arr[result-1] := 1;
\r
761 arr[result-3] := requesttype and $ff;
\r
762 arr[result-4] := requesttype shr 8;
\r
765 function makereversename(const binip:tbinip):ansistring;
\r
771 if binip.family = AF_INET then begin
\r
772 b := htonl(binip.ip);
\r
773 for a := 0 to 3 do begin
\r
774 name := name + inttostr(b shr (a shl 3) and $ff)+'.';
\r
776 name := name + 'in-addr.arpa';
\r
779 if binip.family = AF_INET6 then begin
\r
780 for a := 15 downto 0 do begin
\r
781 b := binip.ip6.u6_addr8[a];
\r
782 name := name + hexchars[b and $f]+'.'+hexchars[b shr 4]+'.';
\r
784 name := name + 'ip6.arpa';
\r
794 decodes DNS format name to a string. does not includes the root dot.
\r
795 doesnt read beyond len.
\r
796 empty result + non null failurereason: failure
\r
797 empty result + null failurereason: internal use
\r
799 function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):ansistring;
\r
801 arr:array[0..sizeof(packet)-1] of byte absolute packet;
\r
807 if (start+numread < 0) or (start+numread >= len) then begin
\r
809 failurereason := 'decoding name: got out of range1';
\r
812 b := arr[start+numread];
\r
813 if b >= $c0 then begin
\r
814 {recursive sub call}
\r
815 if recursion > 10 then begin
\r
817 failurereason := 'decoding name: max recursion';
\r
820 if ((start+numread+1) >= len) then begin
\r
822 failurereason := 'decoding name: got out of range3';
\r
825 a := ((b shl 8) or arr[start+numread+1]) and $3fff;
\r
826 s := decodename(packet,len,a,recursion+1,a);
\r
827 if (s = '') and (failurereason <> '') then begin
\r
831 if result <> '' then result := result + '.';
\r
832 result := result + s;
\r
835 end else if b < 64 then begin
\r
836 if (numread <> 0) and (b <> 0) then result := result + '.';
\r
837 for a := start+numread+1 to start+numread+b do begin
\r
838 if (a >= len) then begin
\r
840 failurereason := 'decoding name: got out of range2';
\r
843 result := result + ansichar(arr[a]);
\r
847 if b = 0 then begin
\r
848 if (result = '') and (recursion = 0) then result := '.';
\r
849 exit; {reached end of name}
\r
852 failurereason := 'decoding name: read invalid char';
\r
859 {==============================================================================}
\r
861 function getrawfromrr(const rrp:trrpointer;len:integer):ansistring;
\r
863 setlength(result,htons(trr(rrp.p^).datalen));
\r
864 uniquestring(result);
\r
865 move(trr(rrp.p^).data,result[1],length(result));
\r
869 function getipfromrr(const rrp:trrpointer;len:integer):tbinip;
\r
871 fillchar(result,sizeof(result),0);
\r
872 case trr(rrp.p^).requesttype of
\r
874 if htons(trr(rrp.p^).datalen) <> 4 then exit;
\r
875 move(trr(rrp.p^).data,result.ip,4);
\r
876 result.family :=AF_INET;
\r
879 querytype_aaaa: begin
\r
880 if htons(trr(rrp.p^).datalen) <> 16 then exit;
\r
881 result.family := AF_INET6;
\r
882 move(trr(rrp.p^).data,result.ip6,16);
\r
890 procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);
\r
894 state.resultaction := action_done;
\r
895 state.resultstr := '';
\r
896 case trr(rrp.p^).requesttype of
\r
897 querytype_a{$ifdef ipv6},querytype_aaaa{$endif}: begin
\r
898 state.resultbin := getipfromrr(rrp,len);
\r
900 querytype_txt:begin
\r
901 {TXT returns a raw string}
\r
902 state.resultstr := copy(getrawfromrr(rrp,len),2,9999);
\r
903 fillchar(state.resultbin,sizeof(state.resultbin),0);
\r
906 {MX is a name after a 16 bits word}
\r
907 state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+12,0,a);
\r
908 fillchar(state.resultbin,sizeof(state.resultbin),0);
\r
911 {other reply types (PTR, MX) return a hostname}
\r
912 state.resultstr := decodename(state.recvpacket,state.recvpacketlen,taddrint(rrp.p)-taddrint(@state.recvpacket)+10,0,a);
\r
913 fillchar(state.resultbin,sizeof(state.resultbin),0);
\r
917 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);
\r
919 {destroy things properly}
\r
920 state.resultstr := '';
\r
921 state.queryname := '';
\r
922 state.rrdata := '';
\r
923 fillchar(state,sizeof(state),0);
\r
924 state.queryname := name;
\r
925 state.parsepacket := false;
\r
928 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);
\r
930 setstate_request_init(name,state);
\r
931 state.forwardfamily := family;
\r
933 if family = AF_INET6 then state.requesttype := querytype_aaaa else
\r
935 state.requesttype := querytype_a;
\r
938 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);
\r
940 setstate_request_init(makereversename(binip),state);
\r
941 state.requesttype := querytype_ptr;
\r
944 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);
\r
946 setstate_request_init(name,state);
\r
947 state.requesttype := requesttype;
\r
951 procedure setstate_failure(var state:tdnsstate);
\r
953 state.resultstr := '';
\r
954 fillchar(state.resultbin,sizeof(state.resultbin),0);
\r
955 state.resultaction := action_done;
\r
958 procedure state_process(var state:tdnsstate);
\r
964 rrptemp:^trrpointer;
\r
966 if state.parsepacket then begin
\r
967 if state.recvpacketlen < 12 then begin
\r
968 failurereason := 'Undersized packet';
\r
969 state.resultaction := action_ignore;
\r
972 if state.id <> state.recvpacket.id then begin
\r
973 failurereason := 'ID mismatch';
\r
974 state.resultaction := action_ignore;
\r
978 for a := 0 to 3 do begin
\r
979 state.numrr1[a] := htons(state.recvpacket.rrcount[a]);
\r
980 if state.numrr1[a] > maxrrofakind then begin
\r
981 failurereason := 'exceeded maximum RR of a kind';
\r
984 inc(state.numrr2,state.numrr1[a]);
\r
987 setlength(state.rrdata,state.numrr2*sizeof(trrpointer));
\r
989 {- put all replies into a list}
\r
993 for a := 0 to state.numrr1[0]-1 do begin
\r
994 if (ofs < 12) or (ofs > state.recvpacketlen-4) then goto failure;
\r
995 rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r
996 rrptemp.p := @state.recvpacket.payload[ofs-12];
\r
997 rrptemp.ofs := ofs;
\r
998 decodename(state.recvpacket,state.recvpacketlen,ofs,0,b);
\r
999 rrptemp.len := b + 4;
\r
1000 inc(ofs,rrptemp.len);
\r
1003 for a := state.numrr1[0] to state.numrr2-1 do begin
\r
1004 if (ofs < 12) or (ofs > state.recvpacketlen-12) then goto failure;
\r
1005 rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r
1006 if decodename(state.recvpacket,state.recvpacketlen,ofs,0,b) = '' then goto failure;
\r
1007 rrtemp := @state.recvpacket.payload[ofs-12+b]; {rrtemp points to values and result, after initial name}
\r
1008 rrptemp.p := rrtemp;
\r
1009 rrptemp.ofs := ofs; {ofs is start of RR before initial name from start of packet}
\r
1010 rrptemp.namelen := b;
\r
1011 b := htons(rrtemp.datalen);
\r
1012 rrptemp.len := b + 10 + rrptemp.namelen;
\r
1013 inc(ofs,rrptemp.len);
\r
1015 if (ofs <> state.recvpacketlen) then begin
\r
1016 failurereason := 'ofs <> state.packetlen';
\r
1020 {if we requested A or AAAA build a list of all replies}
\r
1021 if (state.requesttype = querytype_a) or (state.requesttype = querytype_aaaa) then begin
\r
1022 state.resultlist := biniplist_new;
\r
1023 for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
\r
1024 rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r
1025 rrtemp := rrptemp.p;
\r
1027 if rrtemp.requesttype = state.requesttype then begin
\r
1028 biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));
\r
1033 {- check for items of the requested type in answer section, if so return success first}
\r
1034 for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
\r
1035 rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r
1036 rrtemp := rrptemp.p;
\r
1038 if rrtemp.requesttype = state.requesttype then begin
\r
1039 setstate_return(rrptemp^,b,state);
\r
1044 {if no items of correct type found, follow first cname in answer section}
\r
1045 for a := state.numrr1[0] to (state.numrr1[0]+state.numrr1[1]-1) do begin
\r
1046 rrptemp := @state.rrdata[1+a*sizeof(trrpointer)];
\r
1047 rrtemp := rrptemp.p;
\r
1049 if rrtemp.requesttype = querytype_cname then begin
\r
1050 state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);
\r
1055 {no cnames found, no items of correct type found}
\r
1056 if state.forwardfamily <> 0 then goto failure;
\r
1060 {here it needs recursed lookup}
\r
1061 {if needing to follow a cname, change state to do so}
\r
1062 inc(state.recursioncount);
\r
1063 if state.recursioncount > maxrecursion then goto failure;
\r
1066 {here, a name needs to be resolved}
\r
1067 if state.queryname = '' then begin
\r
1068 failurereason := 'empty query name';
\r
1072 state.sendpacketlen := buildrequest(state.queryname,state.sendpacket,state.requesttype);
\r
1073 if state.sendpacketlen = 0 then begin
\r
1074 failurereason := 'building request packet failed';
\r
1077 state.id := state.sendpacket.id;
\r
1078 state.resultaction := action_sendquery;
\r
1082 setstate_failure(state);
\r
1086 procedure populatednsserverlist;
\r
1090 if assigned(dnsserverlag) then begin
\r
1091 dnsserverlag.clear;
\r
1093 dnsserverlag := tlist.Create;
\r
1096 dnsserverlist := getsystemdnsservers;
\r
1097 for a := biniplist_getcount(dnsserverlist)-1 downto 0 do dnsserverlag.Add(nil);
\r
1100 procedure cleardnsservercache;
\r
1102 if assigned(dnsserverlag) then begin
\r
1103 dnsserverlag.destroy;
\r
1104 dnsserverlag := nil;
\r
1105 dnsserverlist := '';
\r
1109 function getcurrentsystemnameserverbin(var id:integer):tbinip;
\r
1111 counter : integer;
\r
1113 {override the name server choice here, instead of overriding it wherever it's called
\r
1114 setting ID to -1 causes it to be ignored in reportlag}
\r
1115 if (overridednsserver <> '') then begin
\r
1116 result := ipstrtobinf(overridednsserver);
\r
1117 if result.family <> 0 then begin
\r
1123 if not assigned(dnsserverlag) then populatednsserverlist;
\r
1124 if dnsserverlag.count=0 then raise exception.create('no dns servers available');
\r
1126 if dnsserverlag.count >1 then begin
\r
1127 for counter := dnsserverlag.count-1 downto 1 do begin
\r
1128 if taddrint(dnsserverlag[counter]) < taddrint(dnsserverlag[id]) then id := counter;
\r
1131 result := biniplist_get(dnsserverlist,id);
\r
1134 function getcurrentsystemnameserver(var id:integer):ansistring;
\r
1136 result := ipbintostr(getcurrentsystemnameserverbin(id));
\r
1139 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout
\r
1141 counter : integer;
\r
1144 if (id < 0) or (id >= dnsserverlag.count) then exit;
\r
1145 if lag = -1 then lag := timeoutlag;
\r
1146 for counter := 0 to dnsserverlag.count-1 do begin
\r
1147 temp := taddrint(dnsserverlag[counter]) *15;
\r
1148 if counter=id then temp := temp + lag;
\r
1149 dnsserverlag[counter] := tobject(temp div 16);
\r
1157 procedure initpreferredmode;
\r
1159 if preferredmodeinited then exit;
\r
1160 if useaf <> useaf_default then exit;
\r
1162 if (have_ipv6_connectivity) then
\r
1163 useaf := useaf_preferv6
\r
1165 useaf := useaf_preferv4;
\r
1167 preferredmodeinited := true;
\r
1173 { quick and dirty description of dns packet structure to aid writing and
\r
1174 understanding of parser code, refer to appropriate RFCs for proper specs
\r
1175 - all words are network order
\r
1177 www.google.com A request:
\r
1179 0, 2: random transaction ID
\r
1180 2, 2: flags: only the "recursion desired" bit set. (bit 8 of word)
\r
1181 4, 2: questions: 1
\r
1182 6, 2: answer RR's: 0.
\r
1183 8, 2: authority RR's: 0.
\r
1184 10, 2: additional RR's: 0.
\r
1187 #03 "www" #06 "google" #03 "com" #00
\r
1188 size-4, 2: type: host address (1)
\r
1189 size-2, 2: class: inet (1)
\r
1193 0,2: random transaction ID
\r
1194 2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)
\r
1196 6,4: answer RR's: 2
\r
1197 8,4: authority RR's: 9
\r
1198 10,4: additional RR's: 9
\r
1203 0,2 "c0 0c" "name: www.google.com"
\r
1204 2,2 "00 05" "type: cname for an alias"
\r
1205 4,2 "00 01" "class: inet"
\r
1207 10,2: data length "00 17" (23)
\r
1208 12: the cname name (www.google.akadns.net)
\r
1211 2,2 "00 01" host address
\r
1214 10,2: data length (4)
\r
1216 authority - 9 records
\r
1217 additional - 9 records
\r
1223 4,2: class: inet (0001)
\r
1225 10,2: data size (16)
\r
1228 ptr request: query type 000c
\r
1230 name compression: word "cxxx" in the name, xxx points to offset in the packet}
\r