/[lcore]/trunk/dnsasync.pas
ViewVC logotype

Contents of /trunk/dnsasync.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 149 - (show annotations)
Sun Sep 10 20:02:13 2017 UTC (3 months ago) by plugwash
File size: 11791 byte(s)
Replace obsolete/broken lcoregtklaz with new lcorelazarus
Rename lmessages to lcoremessages due to unit name conflict with Lazarus

1 { Copyright (C) 2005 Bas Steendijk and Peter Green
2 For conditions of distribution and use, see copyright notice in zlib_license.txt
3 which is included in the package
4 ----------------------------------------------------------------------------- }
5
6 //FIXME: this code only ever seems to use one dns server for a request and does
7 //not seem to have any form of retry code.
8
9 unit dnsasync;
10 {$ifdef fpc}
11 {$mode delphi}
12 {$endif}
13 interface
14
15 uses
16 {$ifdef winasyncdns}
17 dnswin,
18 {$endif}
19 lsocket,lcore,
20 classes,binipstuff,dnscore,btime,lcorernd;
21
22 {$include lcoreconfig.inc}
23
24 const
25 numsock=1{$ifdef ipv6}+1{$endif};
26
27 type
28
29 //after completion or cancelation a dnswinasync may be reused
30 tdnsasync=class(tcomponent)
31
32 private
33 //made a load of stuff private that does not appear to be part of the main
34 //public interface. If you make any of it public again please consider the
35 //consequences when using windows dns. --plugwash.
36 sockets: array[0..numsock-1] of tlsocket;
37
38 states: array[0..numsock-1] of tdnsstate;
39
40 destinations: array[0..numsock-1] of tbinip;
41
42 dnsserverids : array[0..numsock-1] of integer;
43 startts:double;
44 {$ifdef winasyncdns}
45 dwas : tdnswinasync;
46 {$endif}
47
48 numsockused : integer;
49 fresultlist : tbiniplist;
50 requestaf : integer;
51 procedure asyncprocess(socketno:integer);
52 procedure receivehandler(sender:tobject;error:word);
53 function sendquery(socketno:integer;const packet:tdnspacket;len:integer):boolean;
54 {$ifdef winasyncdns}
55 procedure winrequestdone(sender:tobject;error:word);
56 {$endif}
57
58 public
59 onrequestdone:tsocketevent;
60
61 //addr and port allow the application to specify a dns server specifically
62 //for this dnsasync object. This is not a recommended mode of operation
63 //because it limits the app to one dns server but is kept for compatibility
64 //and special uses.
65 addr,port:ansistring;
66
67 overrideaf : integer;
68
69 procedure cancel;//cancel an outstanding dns request
70 function dnsresult:ansistring; //get result of dnslookup as a string
71 procedure dnsresultbin(var binip:tbinip); //get result of dnslookup as a tbinip
72 property dnsresultlist : tbiniplist read fresultlist;
73 procedure forwardlookup(const name:ansistring); //start forward lookup,
74 //preferring ipv4
75 procedure reverselookup(const binip:tbinip); //start reverse lookup
76 procedure customlookup(const name:ansistring;querytype:integer); //start custom type lookup
77
78 constructor create(aowner:tcomponent); override;
79 destructor destroy; override;
80
81 end;
82
83 implementation
84
85 uses sysutils;
86
87 constructor tdnsasync.create;
88 begin
89 inherited create(aowner);
90 dnsserverids[0] := -1;
91 sockets[0] := twsocket.create(self);
92 sockets[0].tag := 0;
93 {$ifdef ipv6}
94 dnsserverids[1] := -1;
95 sockets[1] := twsocket.Create(self);
96 sockets[1].tag := 1;
97 {$endif}
98 end;
99
100 destructor tdnsasync.destroy;
101 var
102 socketno : integer;
103 begin
104 for socketno := 0 to numsock -1 do begin
105 if assigned(sockets[socketno]) then begin
106 if dnsserverids[socketno] >= 0 then begin
107 reportlag(dnsserverids[socketno],-1);
108 dnsserverids[socketno] := -1;
109 end;
110 sockets[socketno].release;
111 setstate_request_init('',states[socketno]);
112 end;
113 end;
114
115 {$ifdef winasyncdns}
116 if assigned(dwas) then begin
117 dwas.release;
118 dwas := nil;
119 end;
120 {$endif}
121
122 inherited destroy;
123 end;
124
125 procedure tdnsasync.receivehandler(sender:tobject;error:word);
126 var
127 socketno : integer;
128 Src : TInetSockAddrV;
129 SrcLen : Integer;
130 fromip:tbinip;
131 fromport:ansistring;
132 begin
133 socketno := tlsocket(sender).tag;
134 //writeln('got a reply on socket number ',socketno);
135 fillchar(states[socketno].recvpacket,sizeof(states[socketno].recvpacket),0);
136
137 SrcLen := SizeOf(Src);
138 states[socketno].recvpacketlen := twsocket(sender).ReceiveFrom(@(states[socketno].recvpacket), SizeOf(states[socketno].recvpacket), Src, SrcLen);
139
140 fromip := inaddrvtobinip(Src);
141 fromport := inttostr(htons(src.InAddr.port));
142
143 if ((not comparebinip(fromip,destinations[socketno])) or (fromport <> port)) then begin
144 // writeln('dnsasync received from wrong IP:port ',ipbintostr(fromip),'#',fromport,', expected ',ipbintostr(destinations[socketno]),'#',port);
145 exit;
146 end;
147
148 states[socketno].parsepacket := true;
149 if states[socketno].resultaction <> action_done then begin
150 //we ignore packets that come after we are done
151 if dnsserverids[socketno] >= 0 then begin
152 reportlag(dnsserverids[socketno],trunc((unixtimefloat-startts)*1000000));
153 dnsserverids[socketno] := -1;
154 end;
155 { writeln('received reply');}
156
157 asyncprocess(socketno);
158 //writeln('processed it');
159 end else begin
160 //writeln('ignored it because request is done');
161 end;
162 end;
163
164 function tdnsasync.sendquery(socketno:integer;const packet:tdnspacket;len:integer):boolean;
165 var
166 destination : tbinip;
167 inaddr : tinetsockaddrv;
168 trytolisten:integer;
169 begin
170 { writeln('sendquery ',decodename(state.packet,state.packetlen,12,0,a),' ',state.requesttype);}
171 //writeln('trying to send query on socket number ',socketno);
172 result := false;
173 if len = 0 then exit; {no packet}
174 if sockets[socketno].state <> wsconnected then begin
175 startts := unixtimefloat;
176 if port = '' then port := '53';
177 sockets[socketno].Proto := 'udp';
178 sockets[socketno].ondataavailable := receivehandler;
179
180 {we are going to bind on a random local port for the DNS request, against the kaminsky attack
181 there is a small chance that we're trying to bind on an already used port, so retry a few times}
182 for trytolisten := 3 downto 0 do begin
183 try
184 sockets[socketno].port := inttostr(1024 + randominteger(65536 - 1024));
185 sockets[socketno].listen;
186 except
187 {writeln('failed to listen ',sockets[socketno].localport,' ',trytolisten);}
188 if (trytolisten = 0) then begin
189 result := false;
190 exit;
191 end;
192 end;
193 end;
194
195 end;
196 if addr <> '' then begin
197 dnsserverids[socketno] := -1;
198 destination := ipstrtobinf(addr);
199 end else begin
200 destination := getcurrentsystemnameserverbin(dnsserverids[socketno]);
201 end;
202 destinations[socketno] := destination;
203
204 {$ifdef ipv6}{$ifdef mswindows}
205 if destinations[socketno].family = AF_INET6 then if (requestaf = useaf_default) then requestaf := useaf_preferv6;
206 {$endif}{$endif}
207
208 makeinaddrv(destinations[socketno],port,inaddr);
209 sockets[socketno].sendto(inaddr,sizeof(inaddr), @packet,len);
210 result := true;
211
212
213 end;
214
215 procedure tdnsasync.asyncprocess(socketno:integer);
216 begin
217 state_process(states[socketno]);
218 case states[socketno].resultaction of
219 action_ignore: begin {do nothing} end;
220 action_done: begin
221 {$ifdef ipv6}
222 if (numsockused = 1) or (states[socketno xor 1].resultaction=action_done) then
223 //if using two sockets we need to wait until both sockets are in the done
224 //state before firing the event
225 {$endif}
226 begin
227 fresultlist := biniplist_new;
228 if (numsockused = 1) then begin
229 //writeln('processing for one state');
230 biniplist_addlist(fresultlist,states[0].resultlist);
231 {$ifdef ipv6}
232 end else if (requestaf = useaf_preferv6) then begin
233 //writeln('processing for two states, ipv6 preference');
234 //writeln('merging lists '+biniplist_tostr(states[1].resultlist)+' and '+biniplist_tostr(states[0].resultlist));
235 biniplist_addlist(fresultlist,states[1].resultlist);
236 biniplist_addlist(fresultlist,states[0].resultlist);
237 end else begin
238 //writeln('processing for two states, ipv4 preference');
239 biniplist_addlist(fresultlist,states[0].resultlist);
240 biniplist_addlist(fresultlist,states[1].resultlist);
241 {$endif}
242 end;
243 //writeln(biniplist_tostr(fresultlist));
244 onrequestdone(self,0);
245 end;
246 end;
247 action_sendquery:begin
248 sendquery(socketno,states[socketno].sendpacket,states[socketno].sendpacketlen);
249 end;
250 end;
251 end;
252
253 procedure tdnsasync.forwardlookup;
254 var
255 bip : tbinip;
256 i : integer;
257 begin
258 ipstrtobin(name,bip);
259
260 if bip.family <> 0 then begin
261 // it was an IP address
262 fresultlist := biniplist_new;
263 biniplist_add(fresultlist,bip);
264 onrequestdone(self,0);
265 exit;
266 end;
267
268 if overrideaf = useaf_default then begin
269 {$ifdef ipv6}
270 {$ifdef mswindows}if not (usewindns and (addr = '')) then{$endif}
271 initpreferredmode;
272 {$endif}
273 requestaf := useaf;
274 end else begin
275 requestaf := overrideaf;
276 end;
277
278 {$ifdef winasyncdns}
279 if usewindns and (addr = '') then begin
280 dwas := tdnswinasync.create;
281 dwas.onrequestdone := winrequestdone;
282
283 dwas.forwardlookup(name);
284
285 exit;
286 end;
287 {$endif}
288
289 numsockused := 0;
290 fresultlist := biniplist_new;
291 if (requestaf <> useaf_v6) then begin
292 setstate_forward(name,states[numsockused],af_inet);
293 inc(numsockused);
294 end;
295
296 {$ifdef ipv6}
297 if (requestaf <> useaf_v4) then begin
298 setstate_forward(name,states[numsockused],af_inet6);
299 inc(numsockused);
300 end;
301 {$endif}
302
303 for i := 0 to numsockused-1 do begin
304 asyncprocess(i);
305 end;
306 end;
307
308 procedure tdnsasync.reverselookup;
309 begin
310 {$ifdef winasyncdns}
311 if usewindns and (addr = '') then begin
312 dwas := tdnswinasync.create;
313 dwas.onrequestdone := winrequestdone;
314 dwas.reverselookup(binip);
315 exit;
316 end;
317 {$endif}
318
319 setstate_reverse(binip,states[0]);
320 numsockused := 1;
321 asyncprocess(0);
322 end;
323
324 procedure tdnsasync.customlookup;
325 begin
326 setstate_custom(name,querytype,states[0]);
327 numsockused := 1;
328 asyncprocess(0);
329 end;
330
331 function tdnsasync.dnsresult;
332 begin
333 if states[0].resultstr <> '' then result := states[0].resultstr else begin
334 result := ipbintostr(biniplist_get(fresultlist,0));
335 end;
336 end;
337
338 procedure tdnsasync.dnsresultbin(var binip:tbinip);
339 begin
340 binip := biniplist_get(fresultlist,0);
341 end;
342
343 procedure tdnsasync.cancel;
344 var
345 socketno : integer;
346 begin
347 {$ifdef winasyncdns}
348 if assigned(dwas) then begin
349 dwas.release;
350 dwas := nil;
351 end else
352 {$endif}
353 begin
354 for socketno := 0 to numsock-1 do begin
355 reportlag(dnsserverids[socketno],-1);
356 dnsserverids[socketno] := -1;
357
358 sockets[socketno].close;
359 end;
360
361 end;
362 for socketno := 0 to numsock-1 do begin
363 setstate_failure(states[socketno]);
364
365 end;
366 fresultlist := biniplist_new;
367 onrequestdone(self,0);
368 end;
369
370 {$ifdef winasyncdns}
371 procedure tdnsasync.winrequestdone(sender:tobject;error:word);
372
373 begin
374 if dwas.reverse then begin
375 states[0].resultstr := dwas.name;
376 end else begin
377
378 {$ifdef ipv6}
379 if (requestaf = useaf_preferv4) then begin
380 {prefer mode: sort the IP's}
381 fresultlist := biniplist_new;
382 addipsoffamily(fresultlist,dwas.iplist,af_inet);
383 addipsoffamily(fresultlist,dwas.iplist,af_inet6);
384
385 end else if (requestaf = useaf_preferv6) then begin
386 {prefer mode: sort the IP's}
387 fresultlist := biniplist_new;
388 addipsoffamily(fresultlist,dwas.iplist,af_inet6);
389 addipsoffamily(fresultlist,dwas.iplist,af_inet);
390
391 end else
392 {$endif}
393 begin
394 fresultlist := dwas.iplist;
395 end;
396
397 end;
398 dwas.release;
399 onrequestdone(self,error);
400 end;
401 {$endif}
402 end.

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.5