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

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