source: trunk/Demo/Packages/synapse/dnssend.pas

Last change on this file was 60, checked in by chronos, 12 years ago
File size: 19.2 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 002.007.004 |
3|==============================================================================|
4| Content: DNS client |
5|==============================================================================|
6| Copyright (c)1999-2007, Lukas Gebauer |
7| All rights reserved. |
8| |
9| Redistribution and use in source and binary forms, with or without |
10| modification, are permitted provided that the following conditions are met: |
11| |
12| Redistributions of source code must retain the above copyright notice, this |
13| list of conditions and the following disclaimer. |
14| |
15| Redistributions in binary form must reproduce the above copyright notice, |
16| this list of conditions and the following disclaimer in the documentation |
17| and/or other materials provided with the distribution. |
18| |
19| Neither the name of Lukas Gebauer nor the names of its contributors may |
20| be used to endorse or promote products derived from this software without |
21| specific prior written permission. |
22| |
23| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33| DAMAGE. |
34|==============================================================================|
35| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36| Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
37| All Rights Reserved. |
38|==============================================================================|
39| Contributor(s): |
40|==============================================================================|
41| History: see HISTORY.HTM from distribution package |
42| (Found at URL: http://www.ararat.cz/synapse/) |
43|==============================================================================}
44{: @abstract(DNS client by UDP or TCP)
45Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
46 transfers too!
47
48Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
49}
50
51{$IFDEF FPC}
52 {$MODE DELPHI}
53{$ENDIF}
54{$Q-}
55{$H+}
56
57unit dnssend;
58
59interface
60
61uses
62 SysUtils, Classes,
63 blcksock, synautil, synaip, synsock;
64
65const
66 cDnsProtocol = '53';
67
68 QTYPE_A = 1;
69 QTYPE_NS = 2;
70 QTYPE_MD = 3;
71 QTYPE_MF = 4;
72 QTYPE_CNAME = 5;
73 QTYPE_SOA = 6;
74 QTYPE_MB = 7;
75 QTYPE_MG = 8;
76 QTYPE_MR = 9;
77 QTYPE_NULL = 10;
78 QTYPE_WKS = 11; //
79 QTYPE_PTR = 12;
80 QTYPE_HINFO = 13;
81 QTYPE_MINFO = 14;
82 QTYPE_MX = 15;
83 QTYPE_TXT = 16;
84
85 QTYPE_RP = 17;
86 QTYPE_AFSDB = 18;
87 QTYPE_X25 = 19;
88 QTYPE_ISDN = 20;
89 QTYPE_RT = 21;
90 QTYPE_NSAP = 22;
91 QTYPE_NSAPPTR = 23;
92 QTYPE_SIG = 24; // RFC-2065
93 QTYPE_KEY = 25; // RFC-2065
94 QTYPE_PX = 26;
95 QTYPE_GPOS = 27;
96 QTYPE_AAAA = 28;
97 QTYPE_LOC = 29; // RFC-1876
98 QTYPE_NXT = 30; // RFC-2065
99
100 QTYPE_SRV = 33;
101 QTYPE_NAPTR = 35; // RFC-2168
102 QTYPE_KX = 36;
103 QTYPE_SPF = 99;
104
105 QTYPE_AXFR = 252;
106 QTYPE_MAILB = 253; //
107 QTYPE_MAILA = 254; //
108 QTYPE_ALL = 255;
109
110type
111 {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)
112
113 Note: Are you missing properties for specify server address and port? Look to
114 parent @link(TSynaClient) too!}
115 TDNSSend = class(TSynaClient)
116 private
117 FID: Word;
118 FRCode: Integer;
119 FBuffer: AnsiString;
120 FSock: TUDPBlockSocket;
121 FTCPSock: TTCPBlockSocket;
122 FUseTCP: Boolean;
123 FAnswerInfo: TStringList;
124 FNameserverInfo: TStringList;
125 FAdditionalInfo: TStringList;
126 FAuthoritative: Boolean;
127 FTruncated: Boolean;
128 function CompressName(const Value: AnsiString): AnsiString;
129 function CodeHeader: AnsiString;
130 function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
131 function DecodeLabels(var From: Integer): AnsiString;
132 function DecodeString(var From: Integer): AnsiString;
133 function DecodeResource(var i: Integer; const Info: TStringList;
134 QType: Integer): AnsiString;
135 function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
136 function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
137 QType: Integer):boolean;
138 public
139 constructor Create;
140 destructor Destroy; override;
141
142 {:Query a DNSHost for QType resources correspond to a name. Supported QType
143 values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
144 Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
145 Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
146 Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
147 Qtype_KX.
148
149 Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!
150
151 "Name" is domain name or host name for queried resource. If "name" is
152 IP address, automatically convert to reverse domain form (.in-addr.arpa).
153
154 If result is @true, Reply contains resource records. One record on one line.
155 If Resource record have multiple fields, they are stored on line divided by
156 comma. (example: MX record contains value 'rs.cesnet.cz' with preference
157 number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
158 in resource are converted to string form.}
159 function DNSQuery(Name: AnsiString; QType: Integer;
160 const Reply: TStrings): Boolean;
161 published
162
163 {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
164 property Sock: TUDPBlockSocket read FSock;
165
166 {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
167 property TCPSock: TTCPBlockSocket read FTCPSock;
168
169 {:if @true, then is used TCP protocol instead UDP. It is needed for zone
170 transfers, etc.}
171 property UseTCP: Boolean read FUseTCP Write FUseTCP;
172
173 {:After DNS operation contains ResultCode of DNS operation.
174 Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
175 4-not implemented, 5-refused.}
176 property RCode: Integer read FRCode;
177
178 {:@True, if answer is authoritative.}
179 property Authoritative: Boolean read FAuthoritative;
180
181 {:@True, if answer is truncated to 512 bytes.}
182 property Truncated: Boolean read FTRuncated;
183
184 {:Detailed informations from name server reply. One record per line. Record
185 have comma delimited entries with type number, TTL and data filelds.
186 This information contains detailed information about query reply.}
187 property AnswerInfo: TStringList read FAnswerInfo;
188
189 {:Detailed informations from name server reply. One record per line. Record
190 have comma delimited entries with type number, TTL and data filelds.
191 This information contains detailed information about nameserver.}
192 property NameserverInfo: TStringList read FNameserverInfo;
193
194 {:Detailed informations from name server reply. One record per line. Record
195 have comma delimited entries with type number, TTL and data filelds.
196 This information contains detailed additional information.}
197 property AdditionalInfo: TStringList read FAdditionalInfo;
198 end;
199
200{:A very useful function, and example of it's use is found in the TDNSSend object.
201 This function is used to get mail servers for a domain and sort them by
202 preference numbers. "Servers" contains only the domain names of the mail
203 servers in the right order (without preference number!). The first domain name
204 will always be the highest preferenced mail server. Returns boolean @TRUE if
205 all went well.}
206function GetMailServers(const DNSHost, Domain: AnsiString;
207 const Servers: TStrings): Boolean;
208
209implementation
210
211constructor TDNSSend.Create;
212begin
213 inherited Create;
214 FSock := TUDPBlockSocket.Create;
215 FTCPSock := TTCPBlockSocket.Create;
216 FUseTCP := False;
217 FTimeout := 10000;
218 FTargetPort := cDnsProtocol;
219 FAnswerInfo := TStringList.Create;
220 FNameserverInfo := TStringList.Create;
221 FAdditionalInfo := TStringList.Create;
222 Randomize;
223end;
224
225destructor TDNSSend.Destroy;
226begin
227 FAnswerInfo.Free;
228 FNameserverInfo.Free;
229 FAdditionalInfo.Free;
230 FTCPSock.Free;
231 FSock.Free;
232 inherited Destroy;
233end;
234
235function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
236var
237 n: Integer;
238 s: AnsiString;
239begin
240 Result := '';
241 if Value = '' then
242 Result := #0
243 else
244 begin
245 s := '';
246 for n := 1 to Length(Value) do
247 if Value[n] = '.' then
248 begin
249 Result := Result + Char(Length(s)) + s;
250 s := '';
251 end
252 else
253 s := s + Value[n];
254 if s <> '' then
255 Result := Result + Char(Length(s)) + s;
256 Result := Result + #0;
257 end;
258end;
259
260function TDNSSend.CodeHeader: AnsiString;
261begin
262 FID := Random(32767);
263 Result := CodeInt(FID); // ID
264 Result := Result + CodeInt($0100); // flags
265 Result := Result + CodeInt(1); // QDCount
266 Result := Result + CodeInt(0); // ANCount
267 Result := Result + CodeInt(0); // NSCount
268 Result := Result + CodeInt(0); // ARCount
269end;
270
271function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
272begin
273 Result := CompressName(Name);
274 Result := Result + CodeInt(QType);
275 Result := Result + CodeInt(1); // Type INTERNET
276end;
277
278function TDNSSend.DecodeString(var From: Integer): AnsiString;
279var
280 Len: integer;
281begin
282 Len := Ord(FBuffer[From]);
283 Inc(From);
284 Result := Copy(FBuffer, From, Len);
285 Inc(From, Len);
286end;
287
288function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
289var
290 l, f: Integer;
291begin
292 Result := '';
293 while True do
294 begin
295 if From >= Length(FBuffer) then
296 Break;
297 l := Ord(FBuffer[From]);
298 Inc(From);
299 if l = 0 then
300 Break;
301 if Result <> '' then
302 Result := Result + '.';
303 if (l and $C0) = $C0 then
304 begin
305 f := l and $3F;
306 f := f * 256 + Ord(FBuffer[From]) + 1;
307 Inc(From);
308 Result := Result + DecodeLabels(f);
309 Break;
310 end
311 else
312 begin
313 Result := Result + Copy(FBuffer, From, l);
314 Inc(From, l);
315 end;
316 end;
317end;
318
319function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
320 QType: Integer): AnsiString;
321var
322 Rname: AnsiString;
323 RType, Len, j, x, y, z, n: Integer;
324 R: AnsiString;
325 t1, t2, ttl: integer;
326 ip6: TIp6bytes;
327begin
328 Result := '';
329 R := '';
330 Rname := DecodeLabels(i);
331 RType := DecodeInt(FBuffer, i);
332 Inc(i, 4);
333 t1 := DecodeInt(FBuffer, i);
334 Inc(i, 2);
335 t2 := DecodeInt(FBuffer, i);
336 Inc(i, 2);
337 ttl := t1 * 65536 + t2;
338 Len := DecodeInt(FBuffer, i);
339 Inc(i, 2); // i point to begin of data
340 j := i;
341 i := i + len; // i point to next record
342 if Length(FBuffer) >= (i - 1) then
343 case RType of
344 QTYPE_A:
345 begin
346 R := IntToStr(Ord(FBuffer[j]));
347 Inc(j);
348 R := R + '.' + IntToStr(Ord(FBuffer[j]));
349 Inc(j);
350 R := R + '.' + IntToStr(Ord(FBuffer[j]));
351 Inc(j);
352 R := R + '.' + IntToStr(Ord(FBuffer[j]));
353 end;
354 QTYPE_AAAA:
355 begin
356 for n := 0 to 15 do
357 ip6[n] := ord(FBuffer[j + n]);
358 R := IP6ToStr(ip6);
359 end;
360 QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
361 QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
362 QTYPE_NSAPPTR:
363 R := DecodeLabels(j);
364 QTYPE_SOA:
365 begin
366 R := DecodeLabels(j);
367 R := R + ',' + DecodeLabels(j);
368 for n := 1 to 5 do
369 begin
370 x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
371 Inc(j, 4);
372 R := R + ',' + IntToStr(x);
373 end;
374 end;
375 QTYPE_NULL:
376 begin
377 end;
378 QTYPE_WKS:
379 begin
380 end;
381 QTYPE_HINFO:
382 begin
383 R := DecodeString(j);
384 R := R + ',' + DecodeString(j);
385 end;
386 QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
387 begin
388 R := DecodeLabels(j);
389 R := R + ',' + DecodeLabels(j);
390 end;
391 QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
392 begin
393 x := DecodeInt(FBuffer, j);
394 Inc(j, 2);
395 R := IntToStr(x);
396 R := R + ',' + DecodeLabels(j);
397 end;
398 QTYPE_TXT, QTYPE_SPF:
399 begin
400 R := '';
401 while j < i do
402 R := R + DecodeString(j);
403 end;
404 QTYPE_GPOS:
405 begin
406 R := DecodeLabels(j);
407 R := R + ',' + DecodeLabels(j);
408 R := R + ',' + DecodeLabels(j);
409 end;
410 QTYPE_PX:
411 begin
412 x := DecodeInt(FBuffer, j);
413 Inc(j, 2);
414 R := IntToStr(x);
415 R := R + ',' + DecodeLabels(j);
416 R := R + ',' + DecodeLabels(j);
417 end;
418 QTYPE_SRV:
419 // Author: Dan <ml@mutox.org>
420 begin
421 x := DecodeInt(FBuffer, j);
422 Inc(j, 2);
423 y := DecodeInt(FBuffer, j);
424 Inc(j, 2);
425 z := DecodeInt(FBuffer, j);
426 Inc(j, 2);
427 R := IntToStr(x); // Priority
428 R := R + ',' + IntToStr(y); // Weight
429 R := R + ',' + IntToStr(z); // Port
430 R := R + ',' + DecodeLabels(j); // Server DNS Name
431 end;
432 end;
433 if R <> '' then
434 Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
435 if QType = RType then
436 Result := R;
437end;
438
439function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
440var
441 l: integer;
442begin
443 Result := '';
444 l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout);
445 if l > 0 then
446 Result := WorkSock.RecvBufferStr(l, FTimeout);
447end;
448
449function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
450 QType: Integer):boolean;
451var
452 n, i: Integer;
453 flag, qdcount, ancount, nscount, arcount: Integer;
454 s: AnsiString;
455begin
456 Result := False;
457 Reply.Clear;
458 FAnswerInfo.Clear;
459 FNameserverInfo.Clear;
460 FAdditionalInfo.Clear;
461 FAuthoritative := False;
462 if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
463 begin
464 Result := True;
465 flag := DecodeInt(Buf, 3);
466 FRCode := Flag and $000F;
467 FAuthoritative := (Flag and $0400) > 0;
468 FTruncated := (Flag and $0200) > 0;
469 if FRCode = 0 then
470 begin
471 qdcount := DecodeInt(Buf, 5);
472 ancount := DecodeInt(Buf, 7);
473 nscount := DecodeInt(Buf, 9);
474 arcount := DecodeInt(Buf, 11);
475 i := 13; //begin of body
476 if (qdcount > 0) and (Length(Buf) > i) then //skip questions
477 for n := 1 to qdcount do
478 begin
479 while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
480 Inc(i);
481 Inc(i, 5);
482 end;
483 if (ancount > 0) and (Length(Buf) > i) then // decode reply
484 for n := 1 to ancount do
485 begin
486 s := DecodeResource(i, FAnswerInfo, QType);
487 if s <> '' then
488 Reply.Add(s);
489 end;
490 if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info
491 for n := 1 to nscount do
492 DecodeResource(i, FNameserverInfo, QType);
493 if (arcount > 0) and (Length(Buf) > i) then // decode additional info
494 for n := 1 to arcount do
495 DecodeResource(i, FAdditionalInfo, QType);
496 end;
497 end;
498end;
499
500function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer;
501 const Reply: TStrings): Boolean;
502var
503 WorkSock: TBlockSocket;
504 t: TStringList;
505 b: boolean;
506begin
507 Result := False;
508 if IsIP(Name) then
509 Name := ReverseIP(Name) + '.in-addr.arpa';
510 if IsIP6(Name) then
511 Name := ReverseIP6(Name) + '.ip6.arpa';
512 FBuffer := CodeHeader + CodeQuery(Name, QType);
513 if FUseTCP then
514 WorkSock := FTCPSock
515 else
516 WorkSock := FSock;
517 WorkSock.Bind(FIPInterface, cAnyPort);
518 WorkSock.Connect(FTargetHost, FTargetPort);
519 if FUseTCP then
520 FBuffer := Codeint(length(FBuffer)) + FBuffer;
521 WorkSock.SendString(FBuffer);
522 if FUseTCP then
523 FBuffer := RecvTCPResponse(WorkSock)
524 else
525 FBuffer := WorkSock.RecvPacket(FTimeout);
526 if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer
527 begin
528 t := TStringList.Create;
529 try
530 repeat
531 b := DecodeResponse(FBuffer, Reply, QType);
532 if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer
533 b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]);
534 if b then
535 begin
536 t.AddStrings(AnswerInfo);
537 FBuffer := RecvTCPResponse(WorkSock);
538 if FBuffer = '' then
539 Break;
540 if WorkSock.LastError <> 0 then
541 Break;
542 end;
543 until not b;
544 Reply.Assign(t);
545 Result := True;
546 finally
547 t.free;
548 end;
549 end
550 else //normal query
551 if WorkSock.LastError = 0 then
552 Result := DecodeResponse(FBuffer, Reply, QType);
553end;
554
555{==============================================================================}
556
557function GetMailServers(const DNSHost, Domain: AnsiString;
558 const Servers: TStrings): Boolean;
559var
560 DNS: TDNSSend;
561 t: TStringList;
562 n, m, x: Integer;
563begin
564 Result := False;
565 Servers.Clear;
566 t := TStringList.Create;
567 DNS := TDNSSend.Create;
568 try
569 DNS.TargetHost := DNSHost;
570 if DNS.DNSQuery(Domain, QType_MX, t) then
571 begin
572 { normalize preference number to 5 digits }
573 for n := 0 to t.Count - 1 do
574 begin
575 x := Pos(',', t[n]);
576 if x > 0 then
577 for m := 1 to 6 - x do
578 t[n] := '0' + t[n];
579 end;
580 { sort server list }
581 t.Sorted := True;
582 { result is sorted list without preference numbers }
583 for n := 0 to t.Count - 1 do
584 begin
585 x := Pos(',', t[n]);
586 Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
587 end;
588 Result := True;
589 end;
590 finally
591 DNS.Free;
592 t.Free;
593 end;
594end;
595
596end.
Note: See TracBrowser for help on using the repository browser.