1package DJabberd::DNS;
2use strict;
3use base 'Danga::Socket';
4use fields (
5            'hostname',
6            'callback',
7            'srv',
8            'port',
9            'recurse_count',
10            'became_readable',  # bool
11            'timed_out',        # bool
12            );
13use Carp qw(croak);
14
15use DJabberd::Log;
16our $logger = DJabberd::Log->get_logger();
17
18use Net::DNS;
19my $resolver    = Net::DNS::Resolver->new;
20
21sub srv {
22    my ($class, %opts) = @_;
23
24    foreach (qw(callback domain service)) {
25        croak("No '$_' field") unless $opts{$_};
26    }
27
28    my $hostname = delete $opts{'domain'};
29    my $callback = delete $opts{'callback'};
30    my $service  = delete $opts{'service'};
31    my $port     = delete $opts{'port'};
32    my $recurse_count = delete($opts{'recurse_count'}) || 0;
33    croak "unknown opts" if %opts;
34
35    # default port for s2s
36    $port ||= 5269 if $service eq "_xmpp-server._tcp";
37    croak("No specified 'port'") unless $port;
38
39    # testing support
40    if ($service eq "_xmpp-server._tcp") {
41        my $endpt = DJabberd->fake_s2s_peer($hostname);
42        if ($endpt) {
43            $callback->($endpt);
44            return;
45        }
46    }
47
48    my $pkt = Net::DNS::Packet->new("$service.$hostname", "SRV", "IN");
49
50    $logger->debug("pkt = $pkt");
51    my $sock = $resolver->bgsend($pkt);
52    $logger->debug("sock = $sock");
53    my $self = $class->SUPER::new($sock);
54
55    $self->{hostname} = $hostname;
56    $self->{callback} = $callback;
57    $self->{srv}      = $service;
58    $self->{port}     = $port;
59    $self->{recurse_count} = $recurse_count;
60
61    $self->{became_readable} = 0;
62    $self->{timed_out}       = 0;
63
64    # TODO: make DNS timeout configurable
65    Danga::Socket->AddTimer(5.0, sub {
66        return if $self->{became_readable};
67        $self->{timed_out} = 1;
68        $logger->debug("DNS 'SRV' lookup for '$hostname' timed out");
69        $callback->();
70        $self->close;
71    });
72
73    $self->watch_read(1);
74}
75
76sub new {
77    my ($class, %opts) = @_;
78
79    foreach (qw(hostname callback port)) {
80        croak("No '$_' field") unless $opts{$_};
81    }
82
83    my $hostname = delete $opts{'hostname'};
84    my $callback = delete $opts{'callback'};
85    my $port     = delete $opts{'port'};
86    my $recurse_count = delete($opts{'recurse_count'}) || 0;
87    croak "unknown opts" if %opts;
88
89    if ($hostname =~/^\d+\.\d+\.\d+\.\d+$/) {
90        # we already have the IP, lets not looking it up
91        $logger->debug("Skipping lookup for '$hostname', it is already the IP");
92        $callback->(DJabberd::IPEndPoint->new($hostname, $port));
93        return;
94    }
95
96
97    my $sock = $resolver->bgsend($hostname);
98    my $self = $class->SUPER::new($sock);
99
100    $self->{hostname} = $hostname;
101    $self->{callback} = $callback;
102    $self->{port}     = $port;
103    $self->{recurse_count} = $recurse_count;
104
105    $self->{became_readable} = 0;
106    $self->{timed_out}       = 0;
107
108    # TODO: make DNS timeout configurable, remove duplicate code
109    Danga::Socket->AddTimer(5.0, sub {
110        return if $self->{became_readable};
111        $self->{timed_out} = 1;
112        $logger->debug("DNS 'A' lookup for '$hostname' timed out");
113        $callback->();
114        $self->close;
115    });
116
117    $self->watch_read(1);
118}
119
120# TODO: verify response is for correct thing?  or maybe Net::DNS does that?
121# TODO: lots of other stuff.
122sub event_read {
123    my $self = shift;
124
125    if ($self->{timed_out}) {
126        $self->close;
127        return;
128    }
129    $self->{became_readable} = 1;
130
131    if ($self->{srv}) {
132        $logger->debug("DNS socket $self->{sock} became readable for 'srv'");
133        return $self->event_read_srv;
134    } else {
135        $logger->debug("DNS socket $self->{sock} became readable for 'a'");
136        return $self->event_read_a;
137    }
138}
139
140sub event_read_a {
141    my $self = shift;
142
143    my $sock = $self->{sock};
144    my $cb   = $self->{callback};
145
146    my $packet = $resolver->bgread($sock);
147
148    my @ans = $packet->answer;
149
150    for my $ans (@ans) {
151        my $rv = eval {
152            if ($ans->isa('Net::DNS::RR::CNAME')) {
153                if ($self->{recurse_count} < 5) {
154                    $self->close;
155                    DJabberd::DNS->new(hostname => $ans->cname,
156                                       port     => $self->{port},
157                                       callback => $cb,
158                                       recurse_count => $self->{recurse_count}+1);
159                }
160                else {
161                    # Too much recursion
162                    $logger->warn("Too much CNAME recursion while resolving ".$self->{hostname});
163                    $self->close;
164                    $cb->();
165                }
166            } elsif ($ans->isa("Net::DNS::RR::PTR")) {
167                $logger->debug("Ignoring RR response for $self->{hostname}");
168            }
169            else {
170                $cb->(DJabberd::IPEndPoint->new($ans->address, $self->{port}));
171            }
172            $self->close;
173            1;
174        };
175        if ($@) {
176            $self->close;
177            die "ERROR in DNS world: [$@]\n";
178        }
179        return if $rv;
180    }
181
182    # no result
183    $self->close;
184    $cb->();
185}
186
187sub event_read_srv {
188    my $self = shift;
189
190    my $sock = $self->{sock};
191    my $cb   = $self->{callback};
192
193    my $packet = $resolver->bgread($sock);
194    my @ans = $packet->answer;
195
196    # FIXME: is this right?  right order and direction?
197    my @targets = sort {
198        $a->priority <=> $b->priority ||
199        $a->weight   <=> $b->weight
200    } grep { ref $_ eq "Net::DNS::RR::SRV" && $_->port } @ans;
201
202    unless (@targets) {
203        # no result, fallback to an A lookup
204        $self->close;
205        $logger->debug("DNS socket $sock for 'srv' had nothing, falling back to 'a' lookup");
206        DJabberd::DNS->new(hostname => $self->{hostname},
207                           port     => $self->{port},
208                           callback => $cb);
209        return;
210    }
211
212    # FIXME:  we only do the first target now.  should do a chain.
213    $logger->debug("DNS socket $sock for 'srv' found stuff, now doing hostname lookup on " . $targets[0]->target);
214    DJabberd::DNS->new(hostname => $targets[0]->target,
215                       port     => $targets[0]->port,
216                       callback => $cb);
217    $self->close;
218}
219
220package DJabberd::IPEndPoint;
221sub new {
222    my ($class, $addr, $port) = @_;
223    return bless { addr => $addr, port => $port };
224}
225
226sub addr { $_[0]{addr} }
227sub port { $_[0]{port} }
228
2291;
230