change uint32 from longword to cardinal for posix delphi
[lcore.git] / 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 probably want to use dnsasync or dnssync or write a similar\r
10   wrapper unit of their 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   relevant 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 succeeded or failed)\r
24 \r
25   callers should resend the last packet they tried to send if they have not\r
26   been asked to send a new packet for more than some timeout value they choose.\r
27 \r
28   when a packet is received the application should put the packet in\r
29   recvbuf/recvbuflen , set state.parsepacket and call state_process again\r
30 \r
31   once the app gets action_done it can determine success or failure in the\r
32   following ways.\r
33 \r
34   on failure state.resultstr will be an empty string and state.resultbin will\r
35   be zeroed out (easily 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 prefers IPv6 but wants IPv4 results as well it must\r
44   check them separately.\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 these up if required.\r
50 \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
53   of a timeout.\r
54 \r
55 \r
56   hosts file support:\r
57 \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
61 \r
62   the current implementation will automatically periodically reload the file into\r
63   a fast lookup cache if the file changed.\r
64 \r
65   both forward and reverse lookups are supported.\r
66 \r
67   a single IP having multiple hostnames, so "192.0.2.1 foo bar" is supported.\r
68 \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
71 }\r
72 unit dnscore;\r
73 \r
74 {$ifdef fpc}{$mode delphi}{$endif}\r
75 \r
76 {$include lcoreconfig.inc}\r
77 \r
78 interface\r
79 \r
80 uses binipstuff,classes,pgtypes,lcorernd;\r
81 \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
85 dnsserverlist).\r
86 \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
89 \r
90 const\r
91   useaf_default=0;\r
92   useaf_preferv4=1;\r
93   useaf_preferv6=2;\r
94   useaf_v4=3;\r
95   useaf_v6=4;\r
96 {\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
99 }\r
100 var useaf:integer = useaf_default;\r
101 \r
102 {\r
103 (temporarily) use a different nameserver, regardless of the dnsserverlist\r
104 }\r
105 var overridednsserver:ansistring;\r
106 \r
107 const\r
108   maxnamelength=127;\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
112   action_ignore=0;\r
113   action_done=1;\r
114   action_sendquery=2;\r
115   querytype_a=1;\r
116   querytype_cname=5;\r
117   querytype_aaaa=28;\r
118   querytype_a6=38;\r
119   querytype_ptr=12;\r
120   querytype_ns=2;\r
121   querytype_soa=6;\r
122   querytype_mx=15;\r
123   querytype_txt=16;\r
124   querytype_spf=99;\r
125   maxrecursion=50;\r
126   maxrrofakind=32;\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
130 \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
133 type\r
134   dvar=array[0..0] of byte;\r
135   pdvar=^dvar;\r
136   tdnspacket=packed record\r
137     id:word;\r
138     flags:word;\r
139     rrcount:array[0..3] of word;\r
140     payload:array[0..511-12] of byte;\r
141   end;\r
142 \r
143 \r
144 \r
145   tdnsstate=record\r
146     id:word;\r
147     recursioncount:integer;\r
148     queryname:ansistring;\r
149     requesttype:word;\r
150     parsepacket:boolean;\r
151     resultstr:ansistring;\r
152     resultbin:tbinip;\r
153     resultlist:tbiniplist;\r
154     resultaction:integer;\r
155     numrr1:array[0..3] of integer;\r
156     numrr2:integer;\r
157     rrdata:ansistring;\r
158     sendpacketlen:integer;\r
159     sendpacket:tdnspacket;\r
160     recvpacketlen:integer;\r
161     recvpacket:tdnspacket;\r
162     forwardfamily:integer;\r
163   end;\r
164 \r
165   trr=packed record\r
166     requesttypehi:byte;\r
167     requesttype:byte;\r
168     clas:word;\r
169     ttl:integer;\r
170     datalen:word;\r
171     data:array[0..511] of byte;\r
172   end;\r
173 \r
174   trrpointer=packed record\r
175     p:pointer;\r
176     ofs:integer;\r
177     len:integer;\r
178     namelen:integer;\r
179   end;\r
180 \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
184 \r
185 //function buildrequest(const name:string;var packet:tdnspacket;requesttype:word):integer;\r
186 \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
189 \r
190 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);\r
191 \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
195 \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
199 \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
202 \r
203 procedure state_process(var state:tdnsstate);\r
204 \r
205 //function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):string;\r
206 \r
207 procedure populatednsserverlist;\r
208 procedure cleardnsservercache;\r
209 \r
210 var\r
211   dnsserverlist : tbiniplist;\r
212   dnsserverlag:tlist;\r
213 //  currentdnsserverno : integer;\r
214 \r
215 \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
222 \r
223 //var\r
224 //  unixnameservercache:string;\r
225 { $endif}\r
226 \r
227 \r
228 {$ifdef ipv6}\r
229 procedure initpreferredmode;\r
230 \r
231 var\r
232   preferredmodeinited:boolean;\r
233 \r
234 {$endif}\r
235 \r
236 var\r
237   failurereason:ansistring;\r
238 \r
239 function getquerytype(s:ansistring):integer;\r
240 \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
243 \r
244 var\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
252 \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
258 \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
267 \r
268 implementation\r
269 \r
270 uses\r
271   {$ifdef mswindows}windows,{$endif}\r
272   {$ifdef unix}unix,{$endif}  \r
273   lcorelocalips,\r
274   readtxt2,\r
275   ltimevalstuff,\r
276   sysutils;\r
277 \r
278 type\r
279   pbiniplist=^tbiniplist;\r
280   thostsfile_entry=record\r
281     l:tbiniplist;\r
282   end;\r
283   phostsfile_entry=^thostsfile_entry;\r
284 \r
285   thostsfile_reverseentry=record\r
286     name:ansistring;\r
287   end;\r
288   phostsfile_reverseentry=^thostsfile_reverseentry;\r
289 \r
290 \r
291 function hostsfile_findbyname(const name:ansistring):integer;\r
292 begin\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
297     end else begin\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
300     end;\r
301   end;\r
302 end;\r
303 \r
304 \r
305 function hostsfile_forwardlookuplist(const name:ansistring):tbiniplist;\r
306 var\r
307   index:integer;\r
308   l:tbiniplist;\r
309 begin\r
310   hostsfile_init;\r
311   index := hostsfile_findbyname(name);\r
312 \r
313   result := biniplist_new;\r
314 \r
315   if (index >= 0) then begin\r
316     l := phostsfile_entry(hostsfile_entries.objects[index]).l;\r
317 \r
318     {$ifdef ipv6}\r
319     if (useaf <> useaf_v6) and (useaf <> useaf_preferv6) then\r
320     {$endif}\r
321     begin\r
322       addipsoffamily(result,l,af_inet);\r
323     end;\r
324     {$ifdef ipv6}\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
329       end;\r
330     end;\r
331     {$endif}\r
332   end;\r
333 end;\r
334 \r
335 procedure hostsfile_clearreverse;\r
336 var\r
337   index:integer;\r
338 begin\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
342   end;\r
343   hostsfile_reverseentries.clear;\r
344 end;\r
345 \r
346 \r
347 procedure hostsfile_initreverse;\r
348 var\r
349   index,index2:integer;\r
350   l:tbiniplist;\r
351   a,countbefore:integer;\r
352   ip:tbinip;\r
353   s:ansistring;\r
354   he:phostsfile_reverseentry;\r
355 begin\r
356   hostsfile_init;\r
357   if hostsfile_reverseinited then exit;\r
358   hostsfile_reverseinited := true;\r
359 \r
360   hostsfile_clearreverse;\r
361 \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
368 \r
369       countbefore := hostsfile_reverseentries.count;\r
370       index2 := hostsfile_reverseentries.Add(s);\r
371       if (hostsfile_reverseentries.count > countbefore) then begin\r
372         new(he);\r
373         hostsfile_reverseentries.objects[index2] := tobject(he);\r
374         he.name := hostsfile_entries[index];\r
375       end;\r
376 \r
377     end;\r
378   end;\r
379 end;\r
380 \r
381 function hostsfile_reverselookup(ip:tbinip):ansistring;\r
382 var\r
383   index:integer;\r
384   s:ansistring;\r
385 begin\r
386   hostsfile_initreverse;\r
387   result := '';\r
388   s := ipbintostr(ip);\r
389 \r
390   if hostsfile_reverseentries.find(s,index) then begin\r
391     result := phostsfile_reverseentry(hostsfile_reverseentries.objects[index]).name;\r
392   end;\r
393 end;\r
394 \r
395 procedure hostsfile_clear;\r
396 var\r
397   index:integer;\r
398 begin\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
402   end;\r
403   hostsfile_entries.clear;\r
404 \r
405   hostsfile_clearreverse;\r
406 \r
407   hostsfile_lastfileage := 0;\r
408   hostsfile_lastcheckts := 0;\r
409 end;\r
410 \r
411 procedure hostsfile_add(const name:ansistring;const ip:tbinip);\r
412 var\r
413 \r
414   a,index,countbefore:integer;\r
415 \r
416   ip2:tbinip;\r
417   he:phostsfile_entry;\r
418   l:tbiniplist;\r
419 begin\r
420 \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
425 \r
426   if (hostsfile_entries.count > countbefore) then begin\r
427    // writeln('name newly added ',name,' ',ipbintostr(ip),' ',index);\r
428 \r
429     new(he);\r
430     hostsfile_entries.objects[index] := tobject(he);\r
431     he.l := biniplist_new;\r
432     //he.name := name;\r
433   end else begin\r
434    // writeln('name found ',name,' ',ipbintostr(ip),' ',index);\r
435     //search for IP match\r
436 \r
437     he := phostsfile_entry(hostsfile_entries.objects[index]);\r
438     l := he.l;\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
443         exit; //duplicate\r
444       end;\r
445     end;\r
446   end;\r
447   //add it\r
448   biniplist_add(he.l,ip);\r
449 end;\r
450 \r
451 \r
452 function getts:integer;\r
453 {$ifdef mswindows}\r
454 begin\r
455   result := GetTickCount;\r
456 {$else}\r
457 var\r
458   temp:ttimeval;\r
459 begin\r
460   gettimemonotonic(temp);\r
461   result := ((temp.tv_usec div 1000) + (temp.tv_sec * 1000));\r
462 {$endif}\r
463 end;\r
464 \r
465 \r
466 function gethostsfilename:ansistring;\r
467 var\r
468 {$ifdef mswindows}\r
469   windir:array [0..255] of ansichar;\r
470 \r
471   GetSystemWindowsDirectoryA:function(buffer:pansichar;size:integer):integer; stdcall;\r
472   dllhandle:thandle;\r
473   OsVersion                  : TOSVersionInfo;\r
474 {$endif}\r
475   filenamesuffix:ansistring;\r
476 begin\r
477     {$ifdef mswindows}\r
478 \r
479     ZeroMemory(@OsVersion, SizeOf(OsVersion));\r
480     OsVersion.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO);\r
481 \r
482     if ((GetVersionEx(OsVersion)) and (OsVersion.dwPlatformId = VER_PLATFORM_WIN32_NT)) then begin\r
483       filenamesuffix := '\system32\drivers\etc\hosts';\r
484     end else begin\r
485       filenamesuffix := '\hosts';\r
486     end;\r
487 \r
488     //first try "user" windows directory. on a multiuser this may not be c:\windows\r
489     GetWindowsDirectoryA(windir,255);\r
490     result := windir;\r
491     if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);\r
492     result := result + filenamesuffix;\r
493 \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
502           result := windir;\r
503           if (copy(result,length(result),1) = '\') then result := copy(result,1,length(result)-1);\r
504           result := result + filenamesuffix;\r
505         end;\r
506       end;\r
507     end;\r
508 \r
509     {$else}\r
510     result := '/etc/hosts';\r
511     {$endif}\r
512 end;\r
513 \r
514 procedure hostsfile_reload;\r
515 label lineend;\r
516 var\r
517   t:treadtxt;\r
518 \r
519   validchar:array[0..255] of boolean;\r
520   ipv4char:array[0..255] of boolean;\r
521   s:ansistring;\r
522   ch:ansichar;\r
523   a,len,field,startindex,labellen:integer;\r
524   lastwasspace,onlyipv4chars:boolean;\r
525   ipstring,hostname:ansistring;\r
526   biniptemp:tbinip;\r
527 begin\r
528   hostsfile_clear;\r
529 \r
530   if hostsfile_disabled then exit;\r
531   hostsfile_reverseinited := false;\r
532 \r
533   //add builtin entries\r
534   hostsfile_add('localhost',ipstrtobinf('127.0.0.1'));\r
535   {$ifdef ipv6}\r
536   hostsfile_add('localhost',ipstrtobinf('::1'));\r
537   {$endif}\r
538 \r
539   if hostsfile_onlylocalhost then exit;\r
540 \r
541   if (hostsfile_filename = '') then hostsfile_filename := gethostsfilename;\r
542 \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
550 \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
555 \r
556   hostsfile_lastfileage := fileage(hostsfile_filename);\r
557   hostsfile_lastcheckts := getts;\r
558   //writeln('------ reloading ',hostsfile_lastfileage);\r
559   try\r
560     t := treadtxt.createf(hostsfile_filename);\r
561   except\r
562     exit;\r
563   end;\r
564   if not assigned(t) then exit;\r
565 \r
566   while not t.eof do begin\r
567     s := t.readline;\r
568 \r
569     len := length(s);\r
570     if (len > 512) then goto lineend; //sanity check\r
571     field := -1;\r
572     lastwasspace := true;\r
573 \r
574     onlyipv4chars := true;\r
575 \r
576     //one extra loop iteration at the end with a "pretend space" for easy parsing\r
577     inc(len);\r
578     ipstring := '';\r
579     hostname := '';\r
580     a := 0;\r
581     while (a <= len) do begin\r
582       inc(a);\r
583       if (a >= len) then ch := ' ' else ch := s[a];\r
584 \r
585       if (ch = '#') then begin\r
586         //pretend the start of a comment is a space and the end of the line\r
587         ch := ' ';\r
588         len := a;\r
589       end;\r
590 \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
598 \r
599             //remove a trailing dot\r
600             //if (labellen = 0) then dec(a);\r
601 \r
602             //hostname must not be an empty string\r
603             if (a - startindex) < 1 then goto lineend;\r
604 \r
605             hostname := copy(s,startindex,a - startindex);\r
606 \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
611 \r
612             if ipstrtobin(ipstring,biniptemp) then begin\r
613               //writeln('!!!hosts file adding ip=',ipstring,'@host=',hostname,'@');\r
614 \r
615               hostsfile_add(hostname,biniptemp);\r
616             end;\r
617 \r
618             //break scan loop\r
619             //a := len;\r
620           end;\r
621 \r
622         end;\r
623 \r
624         lastwasspace := true;\r
625       end else begin\r
626         if lastwasspace then begin\r
627           inc(field);\r
628           startindex := a;\r
629           lastwasspace := false;\r
630           labellen := 0;\r
631         end;\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
638             labellen := 0;\r
639           end else begin\r
640             inc(labellen);\r
641             if (labellen > 63) then goto lineend;\r
642           end;\r
643         end;\r
644       end;\r
645     end;\r
646 lineend:\r
647   end;\r
648   t.destroy;\r
649 \r
650 end;\r
651 \r
652 \r
653 procedure hostsfile_reloadifneeded;\r
654 var\r
655   ts:integer;\r
656 begin\r
657   if (hostsfile_disabled or hostsfile_onlylocalhost or hostsfile_manualreload) then exit;\r
658   if hostsfile_filename = '' then exit;\r
659 \r
660   ts := getts;\r
661   //writeln('reloadifneeded ts=',ts,' oldts=',hostsfile_lastcheckts);\r
662   if not ((ts > hostsfile_lastcheckts + 10000) or (ts < hostsfile_lastcheckts)) then exit;\r
663 \r
664   hostsfile_lastcheckts := ts;\r
665 \r
666   //writeln('reloadifneeded new=',fileage(hostsfile_filename),' old=',hostsfile_lastfileage);\r
667   if fileage(hostsfile_filename) = hostsfile_lastfileage then exit;\r
668   hostsfile_reload;\r
669 end;\r
670 \r
671 procedure hostsfile_init;\r
672 begin\r
673   //writeln('init ',hostsfile_inited);\r
674   if hostsfile_inited then begin\r
675     hostsfile_reloadifneeded;\r
676     exit;\r
677   end;\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
683 \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
688 \r
689   hostsfile_reload;\r
690 end;\r
691 \r
692 procedure dnscore_preinit(alsoreverse:boolean);\r
693 begin\r
694   {$ifdef ipv6}\r
695   initpreferredmode;\r
696   {$endif}\r
697   hostsfile_init;\r
698   populatednsserverlist;\r
699   randomdword;\r
700   if alsoreverse then hostsfile_initreverse;\r
701 end;\r
702 \r
703 \r
704 function getquerytype(s:ansistring):integer;\r
705 begin\r
706   s := uppercase(s);\r
707   result := 0;\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
718 end;\r
719 \r
720 function buildrequest(const name:ansistring;var packet:tdnspacket;requesttype:word):integer;\r
721 var\r
722   a,b:integer;\r
723   s:ansistring;\r
724   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
725 begin\r
726  { writeln('buildrequest: name: ',name);}\r
727   result := 0;\r
728   fillchar(packet,sizeof(packet),0);\r
729   packet.id := randominteger($10000);\r
730 \r
731   packet.flags := htons($0100);\r
732   packet.rrcount[0] := htons($0001);\r
733 \r
734 \r
735   s := copy(name,1,maxnamelength);\r
736   if s = '' then exit;\r
737   if s[length(s)] <> '.' then s := s + '.';\r
738   b := 0;\r
739   {encode name}\r
740   if (s = '.') then begin\r
741     packet.payload[0] := 0;\r
742     result := 12+5;\r
743   end else begin\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
749         b := 0;\r
750       end else begin\r
751         packet.payload[a] := byte(s[a]);\r
752         inc(b);\r
753       end;\r
754     end;\r
755     if b > maxnamefieldlen then exit;\r
756     packet.payload[length(s)-b] := b;\r
757     result := length(s) + 12+5;\r
758   end;\r
759 \r
760   arr[result-1] := 1;\r
761   arr[result-3] := requesttype and $ff;\r
762   arr[result-4] := requesttype shr 8;\r
763 end;\r
764 \r
765 function makereversename(const binip:tbinip):ansistring;\r
766 var\r
767   name:ansistring;\r
768   a,b:integer;\r
769 begin\r
770   name := '';\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
775     end;\r
776     name := name + 'in-addr.arpa';\r
777   end else\r
778   {$ifdef ipv6}\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
783     end;\r
784     name := name + 'ip6.arpa';\r
785   end else\r
786   {$endif}\r
787   begin\r
788     {empty name}\r
789   end;\r
790   result := name;\r
791 end;\r
792 \r
793 {\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
798 }\r
799 function decodename(const packet:tdnspacket;len,start,recursion:integer;var numread:integer):ansistring;\r
800 var\r
801   arr:array[0..sizeof(packet)-1] of byte absolute packet;\r
802   s:ansistring;\r
803   a,b:integer;\r
804 begin\r
805   numread := 0;\r
806   repeat\r
807     if (start+numread < 0) or (start+numread >= len) then begin\r
808       result := '';\r
809       failurereason := 'decoding name: got out of range1';\r
810       exit;\r
811     end;\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
816         result := '';\r
817         failurereason := 'decoding name: max recursion';\r
818         exit;\r
819       end;\r
820       if ((start+numread+1) >= len) then begin\r
821         result := '';\r
822         failurereason := 'decoding name: got out of range3';\r
823         exit;\r
824       end;\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
828         result := '';\r
829         exit;\r
830       end;\r
831       if result <> '' then result := result + '.';\r
832       result := result + s;\r
833       inc(numread,2);\r
834       exit;\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
839           result := '';\r
840           failurereason := 'decoding name: got out of range2';\r
841           exit;\r
842         end;\r
843         result := result + ansichar(arr[a]);\r
844       end;\r
845       inc(numread,b+1);\r
846 \r
847       if b = 0 then begin\r
848         if (result = '') and (recursion = 0) then result := '.';\r
849         exit; {reached end of name}\r
850       end;\r
851     end else begin\r
852       failurereason := 'decoding name: read invalid char';\r
853       result := '';\r
854       exit; {invalid}\r
855     end;\r
856   until false;\r
857 end;\r
858 \r
859 {==============================================================================}\r
860 \r
861 function getrawfromrr(const rrp:trrpointer;len:integer):ansistring;\r
862 begin\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
866 end;\r
867 \r
868 \r
869 function getipfromrr(const rrp:trrpointer;len:integer):tbinip;\r
870 begin\r
871   fillchar(result,sizeof(result),0);\r
872   case trr(rrp.p^).requesttype of\r
873     querytype_a: begin\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
877     end;\r
878     {$ifdef ipv6}\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
883     end;\r
884     {$endif}\r
885   else\r
886     {}\r
887   end;\r
888 end;\r
889 \r
890 procedure setstate_return(const rrp:trrpointer;len:integer;var state:tdnsstate);\r
891 var\r
892   a:integer;\r
893 begin\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
899     end;\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
904     end;\r
905     querytype_mx:begin\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
909     end;\r
910   else\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
914   end;\r
915 end;\r
916 \r
917 procedure setstate_request_init(const name:ansistring;var state:tdnsstate);\r
918 begin\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
926 end;\r
927 \r
928 procedure setstate_forward(const name:ansistring;var state:tdnsstate;family:integer);\r
929 begin\r
930   setstate_request_init(name,state);\r
931   state.forwardfamily := family;\r
932   {$ifdef ipv6}\r
933   if family = AF_INET6 then state.requesttype := querytype_aaaa else\r
934   {$endif}\r
935   state.requesttype := querytype_a;\r
936 end;\r
937 \r
938 procedure setstate_reverse(const binip:tbinip;var state:tdnsstate);\r
939 begin\r
940   setstate_request_init(makereversename(binip),state);\r
941   state.requesttype := querytype_ptr;\r
942 end;\r
943 \r
944 procedure setstate_custom(const name:ansistring; requesttype:integer; var state:tdnsstate);\r
945 begin\r
946   setstate_request_init(name,state);\r
947   state.requesttype := requesttype;\r
948 end;\r
949 \r
950 \r
951 procedure setstate_failure(var state:tdnsstate);\r
952 begin\r
953   state.resultstr := '';\r
954   fillchar(state.resultbin,sizeof(state.resultbin),0);\r
955   state.resultaction := action_done;\r
956 end;\r
957 \r
958 procedure state_process(var state:tdnsstate);\r
959 label recursed;\r
960 label failure;\r
961 var\r
962   a,b,ofs:integer;\r
963   rrtemp:^trr;\r
964   rrptemp:^trrpointer;\r
965 begin\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
970       exit;\r
971     end;\r
972     if state.id <> state.recvpacket.id then begin\r
973       failurereason := 'ID mismatch';\r
974       state.resultaction := action_ignore;\r
975       exit;\r
976     end;\r
977     state.numrr2 := 0;\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
982         goto failure;\r
983       end;\r
984       inc(state.numrr2,state.numrr1[a]);\r
985     end;\r
986 \r
987     setlength(state.rrdata,state.numrr2*sizeof(trrpointer));\r
988 \r
989     {- put all replies into a list}\r
990 \r
991     ofs := 12;\r
992     {get all queries}\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
1001     end;\r
1002 \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
1014     end;\r
1015     if (ofs <> state.recvpacketlen) then begin\r
1016       failurereason := 'ofs <> state.packetlen';\r
1017       goto failure;\r
1018     end;\r
1019 \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
1026         b := rrptemp.len;\r
1027         if rrtemp.requesttype = state.requesttype then begin\r
1028           biniplist_add(state.resultlist,getipfromrr(rrptemp^,b));\r
1029         end;\r
1030       end;\r
1031     end;\r
1032 \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
1037       b := rrptemp.len;\r
1038       if rrtemp.requesttype = state.requesttype then begin\r
1039         setstate_return(rrptemp^,b,state);\r
1040         exit;\r
1041       end;\r
1042     end;\r
1043 \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
1048       b := rrptemp.len;\r
1049       if rrtemp.requesttype = querytype_cname then begin\r
1050         state.queryname := decodename(state.recvpacket,state.recvpacketlen,rrptemp.ofs+12,0,b);\r
1051         goto recursed;\r
1052       end;\r
1053     end;\r
1054 \r
1055     {no cnames found, no items of correct type found}\r
1056     if state.forwardfamily <> 0 then goto failure;\r
1057 \r
1058     goto failure;\r
1059 recursed:\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
1064   end;\r
1065 \r
1066   {here, a name needs to be resolved}\r
1067   if state.queryname = '' then begin\r
1068     failurereason := 'empty query name';\r
1069     goto failure;\r
1070   end;\r
1071 \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
1075     goto failure;\r
1076   end;\r
1077   state.id := state.sendpacket.id;\r
1078   state.resultaction := action_sendquery;\r
1079 \r
1080   exit;\r
1081 failure:\r
1082   setstate_failure(state);\r
1083 end;\r
1084 \r
1085 \r
1086 procedure populatednsserverlist;\r
1087 var\r
1088   a:integer;\r
1089 begin\r
1090   if assigned(dnsserverlag) then begin\r
1091     dnsserverlag.clear;\r
1092   end else begin\r
1093     dnsserverlag := tlist.Create;\r
1094   end;\r
1095 \r
1096   dnsserverlist := getsystemdnsservers;\r
1097   for a := biniplist_getcount(dnsserverlist)-1 downto 0 do dnsserverlag.Add(nil);\r
1098 end;\r
1099 \r
1100 procedure cleardnsservercache;\r
1101 begin\r
1102   if assigned(dnsserverlag) then begin\r
1103     dnsserverlag.destroy;\r
1104     dnsserverlag := nil;\r
1105     dnsserverlist := '';\r
1106   end;\r
1107 end;\r
1108 \r
1109 function getcurrentsystemnameserverbin(var id:integer):tbinip;\r
1110 var\r
1111   counter : integer;\r
1112 begin\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
1118       id := -1;\r
1119       exit;\r
1120     end;\r
1121   end;\r
1122 \r
1123   if not assigned(dnsserverlag) then populatednsserverlist;\r
1124   if dnsserverlag.count=0 then raise exception.create('no dns servers available');\r
1125   id := 0;\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
1129     end;\r
1130   end;\r
1131   result := biniplist_get(dnsserverlist,id);\r
1132 end;\r
1133 \r
1134 function getcurrentsystemnameserver(var id:integer):ansistring;\r
1135 begin\r
1136   result := ipbintostr(getcurrentsystemnameserverbin(id));\r
1137 end;\r
1138 \r
1139 procedure reportlag(id:integer;lag:integer); //lag should be in microseconds and should be -1 to report a timeout\r
1140 var\r
1141   counter : integer;\r
1142   temp : integer;\r
1143 begin\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
1150   end;\r
1151 \r
1152 end;\r
1153 \r
1154 \r
1155 {$ifdef ipv6}\r
1156 \r
1157 procedure initpreferredmode;\r
1158 begin\r
1159   if preferredmodeinited then exit;\r
1160   if useaf <> useaf_default then exit;\r
1161 \r
1162   if (have_ipv6_connectivity) then\r
1163     useaf := useaf_preferv6\r
1164   else\r
1165     useaf := useaf_preferv4;\r
1166 \r
1167   preferredmodeinited := true;\r
1168 end;\r
1169 \r
1170 {$endif}\r
1171 \r
1172 \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
1176 \r
1177 www.google.com A request:\r
1178 \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
1185 12, n: payload:\r
1186   query:\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
1190 \r
1191 reply:\r
1192 \r
1193 0,2: random transaction ID\r
1194 2,2: flags: set: response (bit 15), recursion desired (8), recursion available (7)\r
1195 4,4: questions: 1\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
1199 12: payload:\r
1200   query:\r
1201     ....\r
1202   answer: CNAME\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
1206     6,4: TTL\r
1207     10,2: data length "00 17" (23)\r
1208     12: the cname name (www.google.akadns.net)\r
1209   answer: A\r
1210     0,2 ..\r
1211     2,2 "00 01" host address\r
1212     4,2 ...\r
1213     6,4 ...\r
1214     10,2: data length (4)\r
1215     12,4: binary IP\r
1216   authority - 9 records\r
1217   additional - 9 records\r
1218 \r
1219 \r
1220   ipv6 AAAA reply:\r
1221     0,2: ...\r
1222     2,2: type: 001c\r
1223     4,2: class: inet (0001)\r
1224     6,2: TTL\r
1225     10,2: data size (16)\r
1226     12,16: binary IP\r
1227 \r
1228   ptr request: query type 000c\r
1229 \r
1230 name compression: word "cxxx" in the name, xxx points to offset in the packet}\r
1231 \r
1232 end.\r