73
75
total_queries_completed => 0,
74
76
pending_lookups => { },
75
77
timing_by_query => { },
78
all_lookups => { }, # keyed by "rr_type/domain"
78
81
bless ($self, $class);
85
# Given a domain name, produces a listref of successively stripped down
86
# parent domains, e.g. a domain '2.10.Example.COM' would produce a list:
87
# '2.10.example.com', '10.example.com', 'example.com', 'com', ''
89
sub domain_to_search_list {
91
$domain =~ s/^\.+//; $domain =~ s/\.+\z//; # strip leading and trailing dots
93
if ($domain =~ /\[/) { # don't split address literals
94
@search_keys = ( $domain, '' ); # presumably an address literal
99
push(@search_keys, $domain);
100
last if $domain eq '';
102
$domain = ($domain =~ /^ (?: [^.]* ) \. (.*) \z/xs) ? $1 : '';
104
if (@search_keys > 20) { # enforce some sanity limit
105
@search_keys = @search_keys[$#search_keys-19 .. $#search_keys];
108
return \@search_keys;
82
111
# ---------------------------------------------------------------------------
84
=item $obj = $async->start_lookup($obj)
113
=item $ent = $async->start_lookup($ent, $master_deadline)
86
Register the start of a long-running asynchronous lookup operation. C<$obj>
87
is a hash reference containing the following items:
115
Register the start of a long-running asynchronous lookup operation.
116
C<$ent> is a hash reference containing the following items:
106
135
A string, typically one word, used to describe the type of lookup in log
107
136
messages, such as C<DNSBL>, C<MX>, C<TXT>.
109
=item poll_callback (optional)
111
A code reference, which will be called periodically during the
112
background-processing period. If you will be performing an async lookup on a
113
non-DNS-based service, you will need to implement this so that it checks for
114
new responses and calls C<set_response_packet()> or C<report_id_complete()> as
115
appropriate. DNS-based lookups can leave it undefined, since
116
DnsResolver::poll_responses() will be called automatically anyway.
118
The code reference will be called with one argument, the C<$ent> object.
120
=item completed_callback (optional)
122
A code reference which will be called when an asynchronous task (e.g. a
123
DNS lookup) is completed, either normally, or aborted, e.g. by a timeout.
125
When a task has been reported as completed via C<set_response_packet()>
126
the response (as provided to C<set_response_packet()>) is stored in
127
$ent->{response_packet} (possibly undef, its semantics is defined by the
128
caller). When completion is reported via C<report_id_complete()> or a
129
task was aborted, the $ent->{response_packet} is guaranteed to be undef.
130
If it is necessary to distinguish between the last two cases, the
131
$ent->{status} may be examined for a string 'ABORTING' or 'FINISHED'.
133
The code reference will be called with one argument, the C<$ent> object.
135
138
=item zone (optional)
137
140
A zone specification (typically a DNS zone name - e.g. host, domain, or RBL)
229
233
map { ref $ent->{$_} ? @{$ent->{$_}} : $ent->{$_} }
230
234
qw(sets rules rulename type key) );
236
$self->{pending_lookups}->{$key} = $ent;
232
238
$self->{queries_started}++;
233
239
$self->{total_queries_started}++;
234
$self->{pending_lookups}->{$key} = $ent;
236
240
dbg("async: starting: %s (timeout %.1fs, min %.1fs)%s",
237
241
$ent->{display_id}, $ent->{timeout_initial}, $ent->{timeout_min},
238
242
!$clipped_by_master_deadline ? '' : ', capped by time limit');
242
247
# ---------------------------------------------------------------------------
244
=item $obj = $async->get_lookup($key)
249
=item $ent = $async->bgsend_and_start_lookup($domain, $type, $class, $ent, $cb, %options)
251
A common idiom: calls C<bgsend>, followed by a call to C<start_lookup>,
252
returning the argument $ent object as modified by C<start_lookup> and
253
filled-in with a query ID.
257
sub bgsend_and_start_lookup {
258
my($self, $domain, $type, $class, $ent, $cb, %options) = @_;
260
$domain =~ s/\.+\z//s; # strip trailing dots, these sometimes still sneak in
262
$ent->{query_type} = $type;
263
$ent->{query_domain} = $domain;
264
$ent->{type} = $type if !exists $ent->{type};
265
$cb = $ent->{completed_callback} if !$cb; # compatibility with SA < 3.4
267
my $key = $ent->{key} || '';
269
my $dnskey = uc($type) . '/' . lc($domain);
270
my $dns_query_info = $self->{all_lookups}{$dnskey};
272
if ($dns_query_info) { # DNS query already underway or completed
273
my $id = $ent->{id} = $dns_query_info->{id}; # re-use existing query
274
return if !defined $id; # presumably blocked, or other fatal failure
275
my $id_tail = $id; $id_tail =~ s{^\d+/IN/}{};
276
lc($id_tail) eq lc($dnskey)
277
or info("async: unmatched id %s, key=%s", $id, $dnskey);
279
my $pkt = $dns_query_info->{pkt};
280
if (!$pkt) { # DNS query underway, still waiting for results
281
# just add our query to the existing one
282
push(@{$dns_query_info->{applicants}}, [$ent,$cb]);
283
dbg("async: query %s already underway, adding no.%d %s",
284
$id, scalar @{$dns_query_info->{applicants}},
285
$ent->{rulename} || $key);
287
} else { # DNS query already completed, re-use results
288
# answer already known, just do the callback and be done with it
290
dbg("async: query %s already done, re-using for %s", $id, $key);
292
dbg("async: query %s already done, re-using for %s, callback",
295
$cb->($ent, $pkt); 1;
298
# resignal if alarm went off
299
die "async: (1) $@\n" if $@ =~ /__alarm__ignore__\(.*\)/s;
300
warn sprintf("query %s completed, callback %s failed: %s\n",
307
else { # no existing query, open a new DNS query
308
$dns_query_info = $self->{all_lookups}{$dnskey} = {}; # new query needed
310
my $dns_query_blockages = $self->{main}->{conf}->{dns_query_blocked};
311
if ($dns_query_blockages) {
312
my $search_list = domain_to_search_list($domain);
313
foreach my $parent_domain (@$search_list) {
314
$blocked = $dns_query_blockages->{$parent_domain};
315
last if defined $blocked; # stop at first defined, can be true or false
319
dbg("async: blocked by dns_query_restriction: %s", $dnskey);
321
dbg("async: launching %s for %s", $dnskey, $key);
322
$id = $self->{main}->{resolver}->bgsend($domain, $type, $class, sub {
323
my($pkt, $pkt_id, $timestamp) = @_;
324
# this callback sub is called from DnsResolver::poll_responses()
325
# dbg("async: in a bgsend_and_start_lookup callback, id %s", $pkt_id);
326
if ($pkt_id ne $id) {
327
warn "async: mismatched dns id: got $pkt_id, expected $id\n";
330
$self->set_response_packet($pkt_id, $pkt, $ent->{key}, $timestamp);
331
$dns_query_info->{pkt} = $pkt;
333
foreach my $tuple (@{$dns_query_info->{applicants}}) {
334
my($appl_ent, $appl_cb) = @$tuple;
336
dbg("async: calling callback on key %s%s", $key,
337
!defined $appl_ent->{rulename} ? ''
338
: ", rule ".$appl_ent->{rulename});
341
$appl_cb->($appl_ent, $pkt); 1;
344
# resignal if alarm went off
345
die "async: (2) $@\n" if $@ =~ /__alarm__ignore__\(.*\)/s;
346
warn sprintf("query %s completed, callback %s failed: %s\n",
347
$id, $appl_ent->{key}, $@);
351
delete $dns_query_info->{applicants};
352
dbg("async: query $id completed, no callbacks run") if !$cb_count;
355
return if !defined $id;
356
$dns_query_info->{id} = $ent->{id} = $id;
357
push(@{$dns_query_info->{applicants}}, [$ent,$cb]);
358
$self->start_lookup($ent, $options{master_deadline});
363
# ---------------------------------------------------------------------------
365
=item $ent = $async->get_lookup($key)
246
367
Retrieve the pending-lookup object for the given key C<$key>.
248
369
If the lookup is complete, this will return C<undef>.
250
371
Note that a lookup is still considered "pending" until C<complete_lookups()> is
251
called, even if it has been reported as complete via C<set_response_packet()>
252
or C<report_id_complete()>.
372
called, even if it has been reported as complete via C<set_response_packet()>.
363
465
# A callback routine may generate another DNS query, which may insert
364
466
# an entry into the %$pending hash thus invalidating the each() context.
365
467
# So, make sure that callbacks are not called while the each() context
366
# is open, or avoid using each(). [Bug 6937]
468
# is open. [Bug 6937]
368
# while (my($key,$ent) = each %$pending) {
369
foreach my $key (keys %$pending) {
370
my $ent = $pending->{$key};
470
while (my($key,$ent) = each %$pending) {
371
471
my $id = $ent->{id};
372
if (defined $ent->{poll_callback}) { # call a "poll_callback" if exists
373
# be nice, provide fresh info to a callback routine
374
$ent->{status} = 'FINISHED' if exists $self->{finished}->{$id};
375
# a callback might call set_response_packet() or report_id_complete()
376
# dbg("async: calling poll_callback on key $key");
377
$ent->{poll_callback}->($ent);
379
my $finished = exists $self->{finished}->{$id};
472
if (exists $self->{finished}->{$id}) {
473
delete $self->{finished}->{$id};
382
delete $self->{finished}->{$id};
383
$ent->{status} = 'FINISHED';
384
475
$ent->{finish_time} = $now if !defined $ent->{finish_time};
385
476
my $elapsed = $ent->{finish_time} - $ent->{start_time};
386
477
dbg("async: completed in %.3f s: %s", $elapsed, $ent->{display_id});
388
# call a "completed_callback" sub, if one exists
389
if (defined $ent->{completed_callback}) {
390
# dbg("async: calling completed_callback on key $key");
391
$ent->{completed_callback}->($ent);
393
478
$self->{timing_by_query}->{". $key"} += $elapsed;
394
479
$self->{queries_completed}++;
395
480
$self->{total_queries_completed}++;
465
552
$ent->{display_id} );
467
554
$self->{timing_by_query}->{"X $key"} = $now - $ent->{start_time};
469
if (defined $ent->{completed_callback}) {
470
$ent->{finish_time} = $now if !defined $ent->{finish_time};
471
$ent->{response_packet} = undef;
472
$ent->{status} = 'ABORTING';
473
$ent->{completed_callback}->($ent);
555
$ent->{finish_time} = $now if !defined $ent->{finish_time};
475
556
delete $pending->{$key};
559
# call any remaining callbacks, indicating the query has been aborted
561
my $all_lookups_ref = $self->{all_lookups};
562
foreach my $dnskey (keys %$all_lookups_ref) {
563
my $dns_query_info = $all_lookups_ref->{$dnskey};
565
foreach my $tuple (@{$dns_query_info->{applicants}}) {
566
my($ent, $cb) = @$tuple;
568
dbg("async: calling callback/abort on key %s%s", $dnskey,
569
!defined $ent->{rulename} ? '' : ", rule ".$ent->{rulename});
572
$cb->($ent, undef); 1;
575
# resignal if alarm went off
576
die "async: (2) $@\n" if $@ =~ /__alarm__ignore__\(.*\)/s;
577
warn sprintf("query %s aborted, callback %s failed: %s\n",
578
$dnskey, $ent->{key}, $@);
581
dbg("async: query $dnskey aborted, no callbacks run") if !$cb_count;
583
delete $dns_query_info->{applicants};
477
586
dbg("async: aborted %d remaining lookups", $foundcnt) if $foundcnt > 0;
478
587
delete $self->{last_poll_responses_time};
479
588
$self->{main}->{resolver}->bgabort();
added
removed
lib/Mail/SpamAssassin/AsyncLoop.pm
