From 12ae226ad796fa6c009ae0db47cba240f383c450 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 8 Mar 2005 19:56:15 +0000 Subject: [PATCH 001/106] high performance branch git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@386 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 22 ++++++-- lib/Qpsmtpd/SMTP.pm | 18 ------ lib/Qpsmtpd/Transaction.pm | 110 +++++++++++++++++++++++++++++-------- 3 files changed, 106 insertions(+), 44 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index d3b855e..d8593d8 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -4,6 +4,8 @@ use vars qw($VERSION $LogLevel); use Sys::Hostname; use Qpsmtpd::Constants; +use Qpsmtpd::Transaction; +use Qpsmtpd::Connection; $VERSION = "0.29"; sub TRACE_LEVEL { $LogLevel } @@ -196,10 +198,6 @@ sub _load_plugins { return @ret; } -sub transaction { - return {}; # base class implements empty transaction -} - sub run_hooks { my ($self, $hook) = (shift, shift); my $hooks = $self->{hooks}; @@ -286,6 +284,22 @@ sub spool_dir { return $spool_dir; } +sub transaction { + my $self = shift; + return $self->{_transaction} || $self->reset_transaction(); +} + +sub reset_transaction { + my $self = shift; + $self->run_hooks("reset_transaction") if $self->{_transaction}; + return $self->{_transaction} = Qpsmtpd::Transaction->new(); +} + +sub connection { + my $self = shift; + return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); +} + # For unique filenames. We write to a local tmp dir so we don't need # to make them unpredictable. my $transaction_counter = 0; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index b52564f..791ed99 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -110,24 +110,6 @@ sub start_conversation { } } -sub transaction { - my $self = shift; - return $self->{_transaction} || $self->reset_transaction(); -} - -sub reset_transaction { - my $self = shift; - $self->run_hooks("reset_transaction") if $self->{_transaction}; - return $self->{_transaction} = Qpsmtpd::Transaction->new(); -} - - -sub connection { - my $self = shift; - return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); -} - - sub helo { my ($self, $hello_host, @stuff) = @_; return $self->respond (501, diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 74afeba..9455cea 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -15,6 +15,10 @@ sub start { my %args = @_; my $self = { _rcpt => [], started => time }; bless ($self, $class); + my $sz = $self->config('memory_threshold'); + $sz = 10_000 unless defined($sz); + $self->{_size_threshold} = $sz; + return $self; } sub add_recipient { @@ -57,12 +61,26 @@ sub notes { $self->{_notes}->{$key}; } +sub set_body_start { + my $self = shift; + $self->{_body_start} = $self->body_current_pos; +} + sub body_start { my $self = shift; - @_ and $self->{_body_start} = shift; + @_ and die "body_start now read only"; $self->{_body_start}; } +sub body_current_pos { + my $self = shift; + if ($self->{_body_file}) { + return tell($self->{_body_file}); + } + return $self->{_body_current_pos} || 0; +} + +# TODO - should we create the file here if we're storing as an array? sub body_filename { my $self = shift; return unless $self->{_body_file}; @@ -72,17 +90,41 @@ sub body_filename { sub body_write { my $self = shift; my $data = shift; - unless ($self->{_body_file}) { - $self->{_filename} = $self->temp_file(); - $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) - or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; + if ($self->{_body_file}) { + #warn("body_write to file\n"); + # go to the end of the file + seek($self->{_body_file},0,2) + unless $self->{_body_file_writing}; + $self->{_body_file_writing} = 1; + $self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data) + and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data); + } + else { + #warn("body_write to array\n"); + $self->{_body_array} ||= []; + my $ref = ref($data) eq "SCALAR" ? $data : \$data; + pos($$ref) = 0; + while ($$ref =~ m/\G(.*?\n)/gc) { + push @{ $self->{_body_array} }, $1; + $self->{_body_size} += length($1); + } + if ($$ref =~ m/\G(.+)\z/gc) { + push @{ $self->{_body_array} }, $1; + $self->{_body_size} += length($1); + } + if ($self->{_body_size} >= $self->{_size_threshold}) { + #warn("spooling to disk\n"); + $self->{_filename} = $self->temp_file(); + $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) + or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; + if ($self->{_body_array}) { + foreach my $line (@{ $self->{_body_array} }) { + $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; + } + } + $self->{_body_array} = undef; + } } - # go to the end of the file - seek($self->{_body_file},0,2) - unless $self->{_body_file_writing}; - $self->{_body_file_writing} = 1; - $self->{_body_file}->print(ref $data eq "SCALAR" ? $$data : $data) - and $self->{_body_size} += length (ref $data eq "SCALAR" ? $$data : $data); } sub body_size { @@ -91,22 +133,46 @@ sub body_size { sub body_resetpos { my $self = shift; - return unless $self->{_body_file}; - my $start = $self->{_body_start} || 0; - seek($self->{_body_file}, $start, 0); - $self->{_body_file_writing} = 0; + + if ($self->{_body_file}) { + my $start = $self->{_body_start} || 0; + seek($self->{_body_file}, $start, 0); + $self->{_body_file_writing} = 0; + } + else { + $self->{_body_current_pos} = $self->{_body_start}; + } + 1; } sub body_getline { my $self = shift; - return unless $self->{_body_file}; - my $start = $self->{_body_start} || 0; - seek($self->{_body_file}, $start,0) - if $self->{_body_file_writing}; - $self->{_body_file_writing} = 0; - my $line = $self->{_body_file}->getline; - return $line; + if ($self->{_body_file}) { + my $start = $self->{_body_start} || 0; + seek($self->{_body_file}, $start,0) + if $self->{_body_file_writing}; + $self->{_body_file_writing} = 0; + my $line = $self->{_body_file}->getline; + return $line; + } + else { + return unless $self->{_body_array}; + my $line = $self->{_body_array}->[$self->{_body_current_pos}]; + $self->{_body_current_pos}++; + return $line; + } +} + +sub body_as_string { + my $self = shift; + $self->body_resetpos; + local $/; + my $str = ''; + while (defined(my $line = $self->body_getline)) { + $str .= $line; + } + return $str; } sub DESTROY { From 3922235bcfcd2091f8c308408a348eb75d98c9d8 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 8 Mar 2005 19:59:45 +0000 Subject: [PATCH 002/106] Import Danga libraries. This is a bit evil but we'll just have to track them from the Danga project. This way we get something stable that we know works, plus nobody has to go and track down other libraries. Note that only Danga::Socket is (C) Danga. Everything else is original code and (C) Matt Sergeant. git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@387 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 133 ++++++ lib/Danga/DNS.pm | 170 ++++++++ lib/Danga/DNS/Resolver.pm | 322 ++++++++++++++ lib/Danga/Socket.pm | 831 +++++++++++++++++++++++++++++++++++++ lib/Danga/TimeoutSocket.pm | 49 +++ 5 files changed, 1505 insertions(+) create mode 100644 lib/Danga/Client.pm create mode 100644 lib/Danga/DNS.pm create mode 100644 lib/Danga/DNS/Resolver.pm create mode 100644 lib/Danga/Socket.pm create mode 100644 lib/Danga/TimeoutSocket.pm diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm new file mode 100644 index 0000000..7b13477 --- /dev/null +++ b/lib/Danga/Client.pm @@ -0,0 +1,133 @@ +# $Id: Client.pm,v 1.8 2005/02/14 22:06:38 msergeant Exp $ + +package Danga::Client; +use base 'Danga::TimeoutSocket'; +use fields qw(line closing disable_read can_read_mode); +use Time::HiRes (); + +# 30 seconds max timeout! +sub max_idle_time { 30 } + +sub new { + my Danga::Client $self = shift; + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + + $self->reset_for_next_message; + return $self; +} + +sub reset_for_next_message { + my Danga::Client $self = shift; + $self->{line} = ''; + $self->{disable_read} = 0; + $self->{can_read_mode} = 0; + return $self; +} + +sub get_line { + my Danga::Client $self = shift; + if (!$self->have_line) { + $self->SetPostLoopCallback(sub { $self->have_line ? 0 : 1 }); + #warn("get_line PRE\n"); + $self->EventLoop(); + #warn("get_line POST\n"); + $self->watch_read(0); + } + return if $self->{closing}; + # now have a line. + $self->{alive_time} = time; + $self->{line} =~ s/^(.*?\n)//; + return $1; +} + +sub can_read { + my Danga::Client $self = shift; + my ($timeout) = @_; + my $end = Time::HiRes::time() + $timeout; + warn("Calling can-read\n"); + $self->{can_read_mode} = 1; + if (!length($self->{line})) { + my $old = $self->watch_read(); + $self->watch_read(1); + $self->SetPostLoopCallback(sub { (length($self->{line}) || + (Time::HiRes::time > $end)) ? 0 : 1 }); + #warn("get_line PRE\n"); + $self->EventLoop(); + #warn("get_line POST\n"); + $self->watch_read($old); + } + $self->{can_read_mode} = 0; + $self->SetPostLoopCallback(sub { $self->have_line ? 0 : 1 }); + return if $self->{closing}; + $self->{alive_time} = time; + warn("can_read returning for '$self->{line}'\n"); + return 1 if length($self->{line}); + return; +} + +sub have_line { + my Danga::Client $self = shift; + return 1 if $self->{closing}; + if ($self->{line} =~ /\n/) { + return 1; + } + return 0; +} + +sub event_read { + my Danga::Client $self = shift; + my $bref = $self->read(8192); + return $self->close($!) unless defined $bref; + # $self->watch_read(0); + $self->process_read_buf($bref); +} + +sub process_read_buf { + my Danga::Client $self = shift; + my $bref = shift; + $self->{line} .= $$bref; + return if $self->{can_read_mode}; + return if $::LineMode; + + while ($self->{line} =~ s/^(.*?\n)//) { + my $line = $1; + $self->{alive_time} = time; + my $resp = $self->process_line($line); + if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) } + $self->write($resp) if $resp; + $self->watch_read(0) if $self->{disable_read}; + } +} + +sub disable_read { + my Danga::Client $self = shift; + $self->{disable_read}++; + $self->watch_read(0); +} + +sub enable_read { + my Danga::Client $self = shift; + $self->{disable_read}--; + if ($self->{disable_read} <= 0) { + $self->{disable_read} = 0; + $self->watch_read(1); + } +} + +sub process_line { + my Danga::Client $self = shift; + return ''; +} + +sub close { + my Danga::Client $self = shift; + $self->{closing} = 1; + print "closing @_\n" if $::DEBUG; + $self->SUPER::close(@_); +} + +sub event_err { my Danga::Client $self = shift; $self->close("Error") } +sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") } + +1; diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm new file mode 100644 index 0000000..e57a3a4 --- /dev/null +++ b/lib/Danga/DNS.pm @@ -0,0 +1,170 @@ +# $Id: DNS.pm,v 1.12 2005/02/14 22:06:08 msergeant Exp $ + +package Danga::DNS; + +# This is the query class - it is really just an encapsulation of the +# hosts you want to query, plus the callback. All the hard work is done +# in Danga::DNS::Resolver. + +use fields qw(client hosts num_hosts callback results start); +use strict; + +use Danga::DNS::Resolver; + +my $resolver; + +sub trace { + my $level = shift; + print ("[$$] dns lookup: @_") if $::DEBUG >= $level; +} + +sub new { + my Danga::DNS $self = shift; + my %options = @_; + + $resolver ||= Danga::DNS::Resolver->new(); + + my $client = $options{client}; + $client->disable_read if $client; + + $self = fields::new($self) unless ref $self; + + $self->{hosts} = $options{hosts} ? $options{hosts} : [ $options{host} ]; + $self->{num_hosts} = scalar(@{$self->{hosts}}) || "No hosts supplied"; + $self->{client} = $client; + $self->{callback} = $options{callback} || die "No callback given"; + $self->{results} = {}; + $self->{start} = time; + + if ($options{type}) { + if ($options{type} eq 'TXT') { + if (!$resolver->query_txt($self, @{$self->{hosts}})) { + $client->watch_read(1) if $client; + return; + } + } + elsif ($options{type} eq 'A') { + if (!$resolver->query($self, @{$self->{hosts}})) { + $client->watch_read(1) if $client; + return; + } + } + elsif ($options{type} eq 'PTR') { + if (!$resolver->query($self, @{$self->{hosts}})) { + $client->watch_read(1) if $client; + return; + } + } + elsif ($options{type} eq 'MX') { + if (!$resolver->query_mx($self, @{$self->{hosts}})) { + $client->watch_read(1) if $client; + return; + } + } + else { + die "Unsupported DNS query type: $options{type}"; + } + } + else { + if (!$resolver->query($self, @{$self->{hosts}})) { + $client->watch_read(1) if $client; + return; + } + } + + return $self; +} + +sub run_callback { + my Danga::DNS $self = shift; + my ($result, $query) = @_; + $self->{results}{$query} = $result; + trace(2, "got $query => $result\n"); + eval { + $self->{callback}->($result, $query); + }; + if ($@) { + warn($@); + } +} + +sub DESTROY { + my Danga::DNS $self = shift; + my $now = time; + foreach my $host (@{$self->{hosts}}) { + if (!$self->{results}{$host}) { + print "DNS timeout (presumably) looking for $host after " . ($now - $self->{start}) . " secs\n"; + $self->{callback}->("NXDOMAIN", $host); + } + } + $self->{client}->enable_read if $self->{client}; +} + +1; + +=head1 NAME + +Danga::DNS - a DNS lookup class for the Danga::Socket framework + +=head1 SYNOPSIS + + Danga::DNS->new(%options); + +=head1 DESCRIPTION + +This module performs asynchronous DNS lookups, making use of a single UDP +socket (unlike Net::DNS's bgsend/bgread combination), and blocking reading on +a client until the response comes back (this is useful for e.g. SMTP rDNS +lookups where you want the answer before you see the next SMTP command). + +Currently this module will only perform A or PTR lookups. A rDNS (PTR) lookup +will be performed if the host matches the regexp: C. + +The lookups time out after 15 seconds. + +=head1 API + +=head2 C<< Danga::DNS->new( %options ) >> + +Create a new DNS query. You do not need to store the resulting object as this +class is all done with callbacks. + +Example: + + Danga::DNS->new( + callback => sub { print "Got result: $_[0]\n" }, + host => 'google.com', + ); + +=over 4 + +=item B<[required]> C + +The callback to call when results come in. This should be a reference to a +subroutine. The callback receives two parameters - the result of the DNS lookup +and the host that was looked up. + +=item C + +A host name to lookup. Note that if the hostname is a dotted quad of numbers then +a reverse DNS (PTR) lookup is performend. + +=item C + +An array-ref list of hosts to lookup. + +B One of either C or C is B. + +=item C + +It is possible to specify a C object (or subclass) which you wish +to disable for reading until your DNS result returns. + +=item C + +You can specify one of: I<"A">, I<"PTR"> or I<"TXT"> here. Other types may be +supported in the future. + +=back + +=cut diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm new file mode 100644 index 0000000..ded6e37 --- /dev/null +++ b/lib/Danga/DNS/Resolver.pm @@ -0,0 +1,322 @@ +# $Id: Resolver.pm,v 1.3 2005/02/14 22:06:08 msergeant Exp $ + +package Danga::DNS::Resolver; +use base qw(Danga::Socket); + +use fields qw(res dst id_to_asker id_to_query timeout cache cache_timeout); + +use Net::DNS; +use Socket; +use strict; + +our $last_cleanup = 0; + +sub trace { + my $level = shift; + print ("$::DEBUG/$level [$$] dns lookup: @_") if $::DEBUG >= $level; +} + +sub new { + my Danga::DNS::Resolver $self = shift; + + $self = fields::new($self) unless ref $self; + + my $res = Net::DNS::Resolver->new; + + my $sock = IO::Socket::INET->new( + Proto => 'udp', + LocalAddr => $res->{'srcaddr'}, + LocalPort => ($res->{'srcport'} || undef), + ) || die "Cannot create socket: $!"; + IO::Handle::blocking($sock, 0); + + trace(2, "Using nameserver $res->{nameservers}->[0]:$res->{port}\n"); + my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton($res->{'nameservers'}->[0])); + #my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton('127.0.0.1')); + #my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton('10.2.1.20')); + + $self->{res} = $res; + $self->{dst} = $dst_sockaddr; + $self->{id_to_asker} = {}; + $self->{id_to_query} = {}; + $self->{timeout} = {}; + $self->{cache} = {}; + $self->{cache_timeout} = {}; + + $self->SUPER::new($sock); + + $self->watch_read(1); + + return $self; +} + +sub _query { + my Danga::DNS::Resolver $self = shift; + my ($asker, $host, $type, $now) = @_; + + if ($ENV{NODNS}) { + $asker->run_callback("NXDNS", $host); + return 1; + } + if (exists $self->{cache}{$type}{$host}) { + # print "CACHE HIT!\n"; + $asker->run_callback($self->{cache}{$type}{$host}, $host); + return 1; + } + + my $packet = $self->{res}->make_query_packet($host, $type); + my $packet_data = $packet->data; + + my $h = $packet->header; + my $id = $h->id; + + if (!$self->sock->send($packet_data, 0, $self->{dst})) { + return; + } + + trace(2, "Query: $host ($id)\n"); + + $self->{id_to_asker}->{$id} = $asker; + $self->{id_to_query}->{$id} = $host; + $self->{timeout}->{$id} = $now; + + return 1; +} + +sub query_txt { + my Danga::DNS::Resolver $self = shift; + my ($asker, @hosts) = @_; + + my $now = time(); + + trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve TXT: @hosts\n"); + + foreach my $host (@hosts) { + $self->_query($asker, $host, 'TXT', $now) || return; + } + + # run cleanup every 5 seconds + if ($now - 5 > $last_cleanup) { + $last_cleanup = $now; + $self->_do_cleanup($now); + } + + #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + + return 1; +} + +sub query_mx { + my Danga::DNS::Resolver $self = shift; + my ($asker, @hosts) = @_; + + my $now = time(); + + trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve MX: @hosts\n"); + + foreach my $host (@hosts) { + $self->_query($asker, $host, 'MX', $now) || return; + } + + # run cleanup every 5 seconds + if ($now - 5 > $last_cleanup) { + $last_cleanup = $now; + $self->_do_cleanup($now); + } + + #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + + return 1; +} + +sub query { + my Danga::DNS::Resolver $self = shift; + my ($asker, @hosts) = @_; + + my $now = time(); + + trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve A/PTR: @hosts\n"); + + foreach my $host (@hosts) { + $self->_query($asker, $host, 'A', $now) || return; + } + + # run cleanup every 5 seconds + if ($now - 5 > $last_cleanup) { + $last_cleanup = $now; + $self->_do_cleanup($now); + } + + #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + + return 1; +} + +sub ticker { + my Danga::DNS::Resolver $self = shift; + my $now = time; + # run cleanup every 5 seconds + if ($now - 5 > $last_cleanup) { + $last_cleanup = $now; + $self->_do_cleanup($now); + } +} + +sub _do_cleanup { + my Danga::DNS::Resolver $self = shift; + my $now = shift; + + my $idle = $self->max_idle_time; + + my @to_delete; + while (my ($id, $t) = each(%{$self->{timeout}})) { + if ($t < ($now - $idle)) { + push @to_delete, $id; + } + } + + foreach my $id (@to_delete) { + delete $self->{timeout}{$id}; + my $asker = delete $self->{id_to_asker}{$id}; + my $query = delete $self->{id_to_query}{$id}; + $asker->run_callback("NXDOMAIN", $query); + } + + foreach my $type ('A', 'TXT') { + @to_delete = (); + + while (my ($query, $t) = each(%{$self->{cache_timeout}{$type}})) { + if ($t < $now) { + push @to_delete, $query; + } + } + + foreach my $q (@to_delete) { + delete $self->{cache_timeout}{$type}{$q}; + delete $self->{cache}{$type}{$q}; + } + } +} + +# seconds max timeout! +sub max_idle_time { 30 } + +# Danga::DNS +sub event_err { shift->close("dns socket error") } +sub event_hup { shift->close("dns socket error") } + +sub event_read { + my Danga::DNS::Resolver $self = shift; + + while (my $packet = $self->{res}->bgread($self->sock)) { + my $err = $self->{res}->errorstring; + my $answers = 0; + my $header = $packet->header; + my $id = $header->id; + + my $asker = delete $self->{id_to_asker}->{$id}; + my $query = delete $self->{id_to_query}->{$id}; + delete $self->{timeout}{$id}; + + #print "-Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + if (!$asker) { + trace(1, "No asker for id: $id\n"); + return; + } + + my $now = time(); + my @questions = $packet->question; + #print STDERR "response to ", $questions[0]->string, "\n"; + foreach my $rr ($packet->answer) { + # my $q = shift @questions; + if ($rr->type eq "PTR") { + my $rdns = $rr->ptrdname; + if ($query) { + # NB: Cached as an "A" lookup as there's no overlap and they + # go through the same query() function above + $self->{cache}{A}{$query} = $rdns; + $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + } + $asker->run_callback($rdns, $query); + } + elsif ($rr->type eq "A") { + my $ip = $rr->address; + if ($query) { + $self->{cache}{A}{$query} = $ip; + $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + } + $asker->run_callback($ip, $query); + } + elsif ($rr->type eq "TXT") { + my $txt = $rr->txtdata; + if ($query) { + $self->{cache}{TXT}{$query} = $txt; + $self->{cache_timeout}{TXT}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + } + $asker->run_callback($txt, $query); + } + else { + # came back, but not a PTR or A record + $asker->run_callback("unknown", $query); + } + $answers++; + } + if (!$answers) { + if ($err eq "NXDOMAIN") { + # trace("found => NXDOMAIN\n"); + $asker->run_callback("NXDOMAIN", $query); + } + elsif ($err eq "SERVFAIL") { + # try again??? + print "SERVFAIL looking for $query (Pending: " . keys(%{$self->{id_to_asker}}) . ")\n"; + #$self->query($asker, $query); + $asker->run_callback($err, $query); + #$self->{id_to_asker}->{$id} = $asker; + #$self->{id_to_query}->{$id} = $query; + #$self->{timeout}{$id} = time(); + + } + elsif($err) { + print("error: $err\n"); + $asker->run_callback($err, $query); + } + else { + # trace("no answers\n"); + $asker->run_callback("NXDOMAIN", $query); + } + } + } +} + +use Carp qw(confess); + +sub close { + my Danga::DNS::Resolver $self = shift; + + $self->SUPER::close(shift); + confess "Danga::DNS::Resolver socket should never be closed!"; +} + +1; + +=head1 NAME + +Danga::DNS::Resolver - an asynchronous DNS resolver class + +=head1 SYNOPSIS + + my $res = Danga::DNS::Resolver->new(); + + $res->query($obj, @hosts); # $obj implements $obj->run_callback() + +=head1 DESCRIPTION + +This is a low level DNS resolver class that works within the Danga::Socket +asynchronous I/O framework. Do not attempt to use this class standalone - use +the C class instead. + +=cut diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm new file mode 100644 index 0000000..e94220f --- /dev/null +++ b/lib/Danga/Socket.pm @@ -0,0 +1,831 @@ +########################################################################### + +=head1 NAME + +Danga::Socket - Event-driven async IO class + +=head1 SYNOPSIS + + use base ('Danga::Socket'); + +=head1 DESCRIPTION + +This is an abstract base class which provides the basic framework for +event-driven asynchronous IO. + +=cut + +########################################################################### + +package Danga::Socket; +use strict; + +use vars qw{$VERSION}; +$VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use fields qw(sock fd write_buf write_buf_offset write_buf_size + read_push_back + closed event_watch debug_level); + +use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN + EPIPE EAGAIN EBADF ECONNRESET); + +use Socket qw(IPPROTO_TCP); +use Carp qw{croak confess}; + +use constant TCP_CORK => 3; # FIXME: not hard-coded (Linux-specific too) + +use constant DebugLevel => 0; + +# for epoll definitions: +our $HAVE_SYSCALL_PH = eval { require 'syscall.ph'; 1 } || eval { require 'sys/syscall.ph'; 1 }; +our $HAVE_KQUEUE = eval { require IO::KQueue; 1 }; + +# Explicitly define the poll constants, as either one set or the other won't be +# loaded. They're also badly implemented in IO::Epoll: +# The IO::Epoll module is buggy in that it doesn't export constants efficiently +# (at least as of 0.01), so doing constants ourselves saves 13% of the user CPU +# time +use constant EPOLLIN => 1; +use constant EPOLLOUT => 4; +use constant EPOLLERR => 8; +use constant EPOLLHUP => 16; +use constant EPOLL_CTL_ADD => 1; +use constant EPOLL_CTL_DEL => 2; +use constant EPOLL_CTL_MOD => 3; + +use constant POLLIN => 1; +use constant POLLOUT => 4; +use constant POLLERR => 8; +use constant POLLHUP => 16; +use constant POLLNVAL => 32; + +# keep track of active clients +our ( + $HaveEpoll, # Flag -- is epoll available? initially undefined. + $HaveKQueue, + %DescriptorMap, # fd (num) -> Danga::Socket object + %PushBackSet, # fd (num) -> Danga::Socket (fds with pushed back read data) + $Epoll, # Global epoll fd (for epoll mode only) + $KQueue, # Global kqueue fd (for kqueue mode only) + @ToClose, # sockets to close when event loop is done + %OtherFds, # A hash of "other" (non-Danga::Socket) file + # descriptors for the event loop to track. + $PostLoopCallback, # subref to call at the end of each loop, if defined + ); + +%OtherFds = (); + +##################################################################### +### C L A S S M E T H O D S +##################################################################### + +### (CLASS) METHOD: HaveEpoll() +### Returns a true value if this class will use IO::Epoll for async IO. +sub HaveEpoll { $HaveEpoll }; + +### (CLASS) METHOD: WatchedSockets() +### Returns the number of file descriptors which are registered with the global +### poll object. +sub WatchedSockets { + return scalar keys %DescriptorMap; +} +*watched_sockets = *WatchedSockets; + + +### (CLASS) METHOD: ToClose() +### Return the list of sockets that are awaiting close() at the end of the +### current event loop. +sub ToClose { return @ToClose; } + + +### (CLASS) METHOD: OtherFds( [%fdmap] ) +### Get/set the hash of file descriptors that need processing in parallel with +### the registered Danga::Socket objects. +sub OtherFds { + my $class = shift; + if ( @_ ) { %OtherFds = @_ } + return wantarray ? %OtherFds : \%OtherFds; +} + + +### (CLASS) METHOD: DescriptorMap() +### Get the hash of Danga::Socket objects keyed by the file descriptor they are +### wrapping. +sub DescriptorMap { + return wantarray ? %DescriptorMap : \%DescriptorMap; +} +*descriptor_map = *DescriptorMap; +*get_sock_ref = *DescriptorMap; + +sub init_poller +{ + return if defined $HaveEpoll || $HaveKQueue; + + if ($HAVE_KQUEUE) { + $KQueue = IO::KQueue->new(); + $HaveKQueue = $KQueue >= 0; + if ($HaveKQueue) { + *EventLoop = *KQueueEventLoop; + } + } + else { + $Epoll = eval { epoll_create(1024); }; + $HaveEpoll = $Epoll >= 0; + if ($HaveEpoll) { + *EventLoop = *EpollEventLoop; + } + } + + if (!$HaveEpoll && !$HaveKQueue) { + require IO::Poll; + *EventLoop = *PollEventLoop; + } +} + +### FUNCTION: EventLoop() +### Start processing IO events. +sub EventLoop { + my $class = shift; + + init_poller(); + + if ($HaveEpoll) { + EpollEventLoop($class); + } else { + PollEventLoop($class); + } +} + +### The kqueue-based event loop. Gets installed as EventLoop if IO::KQueue works +### okay. +sub KQueueEventLoop { + my $class = shift; + + foreach my $fd (keys %OtherFds) { + $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), IO::KQueue::EV_ADD()); + } + + while (1) { + my @ret = $KQueue->kevent(1000); + + if (!@ret) { + foreach my $fd ( keys %DescriptorMap ) { + my Danga::Socket $sock = $DescriptorMap{$fd}; + if ($sock->can('ticker')) { + $sock->ticker; + } + } + } + + my @objs; + + foreach my $kev (@ret) { + my ($fd, $filter, $flags, $fflags) = @$kev; + + my Danga::Socket $pob = $DescriptorMap{$fd}; + + # prioritise OtherFds first - likely to be accept() socks (?) + if (!$pob) { + if (my $code = $OtherFds{$fd}) { + $code->($filter); + } + next; + } + + push @objs, [$pob, $fd, $filter, $flags, $fflags]; + } + + # TODO - prioritize the objects + + foreach (@objs) { + my ($pob, $fd, $filter, $flags, $fflags) = @$_; + + DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", + $fd, ref($pob), $flags, time); + + $pob->event_read if $filter == IO::KQueue::EVFILT_READ() && !$pob->{closed}; + $pob->event_write if $filter == IO::KQueue::EVFILT_WRITE() && !$pob->{closed}; + if ($flags == IO::KQueue::EV_EOF() && !$pob->{closed}) { + if ($fflags) { + $pob->event_err; + } else { + $pob->event_hup; + } + } + } + + return unless PostEventLoop(); + } + + exit(0); +} + +### The epoll-based event loop. Gets installed as EventLoop if IO::Epoll loads +### okay. +sub EpollEventLoop { + my $class = shift; + + foreach my $fd ( keys %OtherFds ) { + epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, EPOLLIN); + } + + while (1) { + my @events; + my $i; + my $evcount; + # get up to 1000 events, 1000ms timeout + while ($evcount = epoll_wait($Epoll, 1000, 1000, \@events)) { + EVENT: + for ($i=0; $i<$evcount; $i++) { + my $ev = $events[$i]; + + # it's possible epoll_wait returned many events, including some at the end + # that ones in the front triggered unregister-interest actions. if we + # can't find the %sock entry, it's because we're no longer interested + # in that event. + my Danga::Socket $pob = $DescriptorMap{$ev->[0]}; + my $code; + my $state = $ev->[1]; + + # if we didn't find a Perlbal::Socket subclass for that fd, try other + # pseudo-registered (above) fds. + if (! $pob) { + if (my $code = $OtherFds{$ev->[0]}) { + $code->($state); + } + next; + } + + DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", + $ev->[0], ref($pob), $ev->[1], time); + + $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; + $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; + $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; + $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; + } + return unless PostEventLoop(); + + } + + foreach my $fd ( keys %DescriptorMap ) { + my Danga::Socket $sock = $DescriptorMap{$fd}; + if ($sock->can('ticker')) { + $sock->ticker; + } + } + + print STDERR "Event loop ending; restarting.\n"; + } + exit 0; +} + +sub PostEventLoop { + # fire read events for objects with pushed-back read data + my $loop = 1; + while ($loop) { + $loop = 0; + foreach my $fd (keys %PushBackSet) { + my Danga::Socket $pob = $PushBackSet{$fd}; + next unless (! $pob->{closed} && + $pob->{event_watch} & POLLIN); + $loop = 1; + $pob->event_read; + } + } + + # now we can close sockets that wanted to close during our event processing. + # (we didn't want to close them during the loop, as we didn't want fd numbers + # being reused and confused during the event loop) + $_->close while ($_ = shift @ToClose); + + # now we're at the very end, call callback if defined + if (defined $PostLoopCallback) { + return $PostLoopCallback->(\%DescriptorMap, \%OtherFds); + } + return 1; +} + +### The fallback IO::Poll-based event loop. Gets installed as EventLoop if +### IO::Epoll fails to load. +sub PollEventLoop { + my $class = shift; + + my Danga::Socket $pob; + + while (1) { + # the following sets up @poll as a series of ($poll,$event_mask) + # items, then uses IO::Poll::_poll, implemented in XS, which + # modifies the array in place with the even elements being + # replaced with the event masks that occured. + my @poll; + foreach my $fd ( keys %OtherFds ) { + push @poll, $fd, POLLIN; + } + foreach my $fd ( keys %DescriptorMap ) { + my Danga::Socket $sock = $DescriptorMap{$fd}; + push @poll, $fd, $sock->{event_watch}; + } + return 0 unless @poll; + + my $count = IO::Poll::_poll(1000, @poll); + if (!$count) { + foreach my $fd ( keys %DescriptorMap ) { + my Danga::Socket $sock = $DescriptorMap{$fd}; + if ($sock->can('ticker')) { + $sock->ticker; + } + } + next; + } + + # Fetch handles with read events + while (@poll) { + my ($fd, $state) = splice(@poll, 0, 2); + next unless $state; + + $pob = $DescriptorMap{$fd}; + + if ( !$pob && (my $code = $OtherFds{$fd}) ) { + $code->($state); + next; + } + + $pob->event_read if $state & POLLIN && ! $pob->{closed}; + $pob->event_write if $state & POLLOUT && ! $pob->{closed}; + $pob->event_err if $state & POLLERR && ! $pob->{closed}; + $pob->event_hup if $state & POLLHUP && ! $pob->{closed}; + } + + return unless PostEventLoop(); + } + + exit 0; +} + + +### (CLASS) METHOD: DebugMsg( $format, @args ) +### Print the debugging message specified by the C-style I and +### I +sub DebugMsg { + my ( $class, $fmt, @args ) = @_; + chomp $fmt; + printf STDERR ">>> $fmt\n", @args; +} + + +### METHOD: new( $socket ) +### Create a new Danga::Socket object for the given I which will react +### to events on it during the C. +sub new { + my Danga::Socket $self = shift; + $self = fields::new($self) unless ref $self; + + my $sock = shift; + + $self->{sock} = $sock; + my $fd = fileno($sock); + $self->{fd} = $fd; + $self->{write_buf} = []; + $self->{write_buf_offset} = 0; + $self->{write_buf_size} = 0; + $self->{closed} = 0; + $self->{read_push_back} = []; + + $self->{event_watch} = POLLERR|POLLHUP|POLLNVAL; + + init_poller(); + + if ($HaveEpoll) { + epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, $self->{event_watch}) + and die "couldn't add epoll watch for $fd\n"; + } + elsif ($HaveKQueue) { + # Add them to the queue but disabled for now + $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), + IO::KQueue::EV_ADD() | IO::KQueue::EV_DISABLE()); + $KQueue->EV_SET($fd, IO::KQueue::EVFILT_WRITE(), + IO::KQueue::EV_ADD() | IO::KQueue::EV_DISABLE()); + } + + $DescriptorMap{$fd} = $self; + return $self; +} + + + +##################################################################### +### I N S T A N C E M E T H O D S +##################################################################### + +### METHOD: tcp_cork( $boolean ) +### Turn TCP_CORK on or off depending on the value of I. +sub tcp_cork { + my Danga::Socket $self = shift; + my $val = shift; + + # FIXME: Linux-specific. + setsockopt($self->{sock}, IPPROTO_TCP, TCP_CORK, + pack("l", $val ? 1 : 0)) || die "setsockopt: $!"; +} + +### METHOD: close( [$reason] ) +### Close the socket. The I argument will be used in debugging messages. +sub close { + my Danga::Socket $self = shift; + my $reason = shift || ""; + + my $fd = $self->{fd}; + my $sock = $self->{sock}; + $self->{closed} = 1; + + # we need to flush our write buffer, as there may + # be self-referential closures (sub { $client->close }) + # preventing the object from being destroyed + $self->{write_buf} = []; + + if (DebugLevel) { + my ($pkg, $filename, $line) = caller; + print STDERR "Closing \#$fd due to $pkg/$filename/$line ($reason)\n"; + } + + if ($HaveEpoll) { + if (epoll_ctl($Epoll, EPOLL_CTL_DEL, $fd, $self->{event_watch}) == 0) { + DebugLevel >= 1 && $self->debugmsg("Client %d disconnected.\n", $fd); + } else { + DebugLevel >= 1 && $self->debugmsg("poll->remove failed on fd %d\n", $fd); + } + } + + delete $DescriptorMap{$fd}; + delete $PushBackSet{$fd}; + + # defer closing the actual socket until the event loop is done + # processing this round of events. (otherwise we might reuse fds) + push @ToClose, $sock; + + return 0; +} + + + +### METHOD: sock() +### Returns the underlying IO::Handle for the object. +sub sock { + my Danga::Socket $self = shift; + return $self->{sock}; +} + + +### METHOD: write( $data ) +### Write the specified data to the underlying handle. I may be scalar, +### scalar ref, code ref (to run when there), or undef just to kick-start. +### Returns 1 if writes all went through, or 0 if there are writes in queue. If +### it returns 1, caller should stop waiting for 'writable' events) +sub write { + my Danga::Socket $self; + my $data; + ($self, $data) = @_; + + # nobody should be writing to closed sockets, but caller code can + # do two writes within an event, have the first fail and + # disconnect the other side (whose destructor then closes the + # calling object, but it's still in a method), and then the + # now-dead object does its second write. that is this case. we + # just lie and say it worked. it'll be dead soon and won't be + # hurt by this lie. + return 1 if $self->{closed}; + + my $bref; + + # just queue data if there's already a wait + my $need_queue; + + if (defined $data) { + $bref = ref $data ? $data : \$data; + if ($self->{write_buf_size}) { + push @{$self->{write_buf}}, $bref; + $self->{write_buf_size} += ref $bref eq "SCALAR" ? length($$bref) : 1; + return 0; + } + + # this flag says we're bypassing the queue system, knowing we're the + # only outstanding write, and hoping we don't ever need to use it. + # if so later, though, we'll need to queue + $need_queue = 1; + } + + WRITE: + while (1) { + return 1 unless $bref ||= $self->{write_buf}[0]; + + my $len; + eval { + $len = length($$bref); # this will die if $bref is a code ref, caught below + }; + if ($@) { + if (ref $bref eq "CODE") { + unless ($need_queue) { + $self->{write_buf_size}--; # code refs are worth 1 + shift @{$self->{write_buf}}; + } + $bref->(); + undef $bref; + next WRITE; + } + die "Write error: $@ <$bref>"; + } + + my $to_write = $len - $self->{write_buf_offset}; + my $written = syswrite($self->{sock}, $$bref, $to_write, $self->{write_buf_offset}); + + if (! defined $written) { + if ($! == EPIPE) { + return $self->close("EPIPE"); + } elsif ($! == EAGAIN) { + # since connection has stuff to write, it should now be + # interested in pending writes: + if ($need_queue) { + push @{$self->{write_buf}}, $bref; + $self->{write_buf_size} += $len; + } + $self->watch_write(1); + return 0; + } elsif ($! == ECONNRESET) { + return $self->close("ECONNRESET"); + } + + DebugLevel >= 1 && $self->debugmsg("Closing connection ($self) due to write error: $!\n"); + + return $self->close("write_error"); + } elsif ($written != $to_write) { + DebugLevel >= 2 && $self->debugmsg("Wrote PARTIAL %d bytes to %d", + $written, $self->{fd}); + if ($need_queue) { + push @{$self->{write_buf}}, $bref; + $self->{write_buf_size} += $len; + } + # since connection has stuff to write, it should now be + # interested in pending writes: + $self->{write_buf_offset} += $written; + $self->{write_buf_size} -= $written; + $self->watch_write(1); + return 0; + } elsif ($written == $to_write) { + DebugLevel >= 2 && $self->debugmsg("Wrote ALL %d bytes to %d (nq=%d)", + $written, $self->{fd}, $need_queue); + $self->{write_buf_offset} = 0; + + # this was our only write, so we can return immediately + # since we avoided incrementing the buffer size or + # putting it in the buffer. we also know there + # can't be anything else to write. + return 1 if $need_queue; + + $self->{write_buf_size} -= $written; + shift @{$self->{write_buf}}; + undef $bref; + next WRITE; + } + } +} + +### METHOD: push_back_read( $buf ) +### Push back I (a scalar or scalarref) into the read stream +sub push_back_read { + my Danga::Socket $self = shift; + my $buf = shift; + push @{$self->{read_push_back}}, ref $buf ? $buf : \$buf; + $PushBackSet{$self->{fd}} = $self; +} + +### METHOD: read( $bytecount ) +### Read at most I bytes from the underlying handle; returns scalar +### ref on read, or undef on connection closed. +sub read { + my Danga::Socket $self = shift; + my $bytes = shift; + my $buf; + my $sock = $self->{sock}; + + if (@{$self->{read_push_back}}) { + $buf = shift @{$self->{read_push_back}}; + my $len = length($$buf); + if ($len <= $buf) { + unless (@{$self->{read_push_back}}) { + delete $PushBackSet{$self->{fd}}; + } + return $buf; + } else { + # if the pushed back read is too big, we have to split it + my $overflow = substr($$buf, $bytes); + $buf = substr($$buf, 0, $bytes); + unshift @{$self->{read_push_back}}, \$overflow, + return \$buf; + } + } + + my $res = sysread($sock, $buf, $bytes, 0); + DebugLevel >= 2 && $self->debugmsg("sysread = %d; \$! = %d", $res, $!); + + if (! $res && $! != EWOULDBLOCK) { + # catches 0=conn closed or undef=error + DebugLevel >= 2 && $self->debugmsg("Fd \#%d read hit the end of the road.", $self->{fd}); + return undef; + } + + return \$buf; +} + + +### (VIRTUAL) METHOD: event_read() +### Readable event handler. Concrete deriviatives of Danga::Socket should +### provide an implementation of this. The default implementation will die if +### called. +sub event_read { die "Base class event_read called for $_[0]\n"; } + + +### (VIRTUAL) METHOD: event_err() +### Error event handler. Concrete deriviatives of Danga::Socket should +### provide an implementation of this. The default implementation will die if +### called. +sub event_err { die "Base class event_err called for $_[0]\n"; } + + +### (VIRTUAL) METHOD: event_hup() +### 'Hangup' event handler. Concrete deriviatives of Danga::Socket should +### provide an implementation of this. The default implementation will die if +### called. +sub event_hup { die "Base class event_hup called for $_[0]\n"; } + + +### METHOD: event_write() +### Writable event handler. Concrete deriviatives of Danga::Socket may wish to +### provide an implementation of this. The default implementation calls +### C with an C. +sub event_write { + my $self = shift; + $self->write(undef); +} + + +### METHOD: watch_read( $boolean ) +### Turn 'readable' event notification on or off. +sub watch_read { + my Danga::Socket $self = shift; + return if $self->{closed}; + + my $val = shift; + my $event = $self->{event_watch}; + + $event &= ~POLLIN if ! $val; + $event |= POLLIN if $val; + + # If it changed, set it + if ($event != $self->{event_watch}) { + if ($HaveKQueue) { + $KQueue->EV_SET($self->{fd}, IO::KQueue::EVFILT_READ(), + $val ? IO::KQueue::EV_ENABLE() : IO::KQueue::EV_DISABLE()); + } + elsif ($HaveEpoll) { + epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) + and print STDERR "couldn't modify epoll settings for $self->{fd} " . + "($self) from $self->{event_watch} -> $event\n"; + } + $self->{event_watch} = $event; + } +} + +### METHOD: watch_read( $boolean ) +### Turn 'writable' event notification on or off. +sub watch_write { + my Danga::Socket $self = shift; + return if $self->{closed}; + + my $val = shift; + my $event = $self->{event_watch}; + + $event &= ~POLLOUT if ! $val; + $event |= POLLOUT if $val; + + # If it changed, set it + if ($event != $self->{event_watch}) { + if ($HaveKQueue) { + $KQueue->EV_SET($self->{fd}, IO::KQueue::EVFILT_WRITE(), + $val ? IO::KQueue::EV_ENABLE() : IO::KQueue::EV_DISABLE()); + } + elsif ($HaveEpoll) { + epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) + and print STDERR "couldn't modify epoll settings for $self->{fd} " . + "($self) from $self->{event_watch} -> $event\n"; + } + $self->{event_watch} = $event; + } +} + + +### METHOD: debugmsg( $format, @args ) +### Print the debugging message specified by the C-style I and +### I if the object's C is greater than or equal to the given +### I. +sub debugmsg { + my ( $self, $fmt, @args ) = @_; + confess "Not an object" unless ref $self; + + chomp $fmt; + printf STDERR ">>> $fmt\n", @args; +} + + +### METHOD: peer_ip_string() +### Returns the string describing the peer's IP +sub peer_ip_string { + my Danga::Socket $self = shift; + my $pn = getpeername($self->{sock}) or return undef; + my ($port, $iaddr) = Socket::sockaddr_in($pn); + return Socket::inet_ntoa($iaddr); +} + +### METHOD: peer_addr_string() +### Returns the string describing the peer for the socket which underlies this +### object in form "ip:port" +sub peer_addr_string { + my Danga::Socket $self = shift; + my $pn = getpeername($self->{sock}) or return undef; + my ($port, $iaddr) = Socket::sockaddr_in($pn); + return Socket::inet_ntoa($iaddr) . ":$port"; +} + +### METHOD: as_string() +### Returns a string describing this socket. +sub as_string { + my Danga::Socket $self = shift; + my $ret = ref($self) . ": " . ($self->{closed} ? "closed" : "open"); + my $peer = $self->peer_addr_string; + if ($peer) { + $ret .= " to " . $self->peer_addr_string; + } + return $ret; +} + +### CLASS METHOD: SetPostLoopCallback +### Sets post loop callback function. Pass a subref and it will be +### called every time the event loop finishes. Return 1 from the sub +### to make the loop continue, else it will exit. The function will +### be passed two parameters: \%DescriptorMap, \%OtherFds. +sub SetPostLoopCallback { + my ($class, $ref) = @_; + $PostLoopCallback = (defined $ref && ref $ref eq 'CODE') ? $ref : undef; +} + +##################################################################### +### U T I L I T Y F U N C T I O N S +##################################################################### + +our $SYS_epoll_create = eval { &SYS_epoll_create } || 254; # linux-ix86 default + +# epoll_create wrapper +# ARGS: (size) +sub epoll_create { + my $epfd = eval { syscall($SYS_epoll_create, $_[0]) }; + return -1 if $@; + return $epfd; +} + +# epoll_ctl wrapper +# ARGS: (epfd, op, fd, events) +our $SYS_epoll_ctl = eval { &SYS_epoll_ctl } || 255; # linux-ix86 default +sub epoll_ctl { + syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLL", $_[3], $_[2])); +} + +# epoll_wait wrapper +# ARGS: (epfd, maxevents, timeout, arrayref) +# arrayref: values modified to be [$fd, $event] +our $epoll_wait_events; +our $epoll_wait_size = 0; +our $SYS_epoll_wait = eval { &SYS_epoll_wait } || 256; # linux-ix86 default +sub epoll_wait { + # resize our static buffer if requested size is bigger than we've ever done + if ($_[1] > $epoll_wait_size) { + $epoll_wait_size = $_[1]; + $epoll_wait_events = pack("LLL") x $epoll_wait_size; + } + my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0); + for ($_ = 0; $_ < $ct; $_++) { + @{$_[3]->[$_]}[1,0] = unpack("LL", substr($epoll_wait_events, 12*$_, 8)); + } + return $ct; +} + + + +1; + + +# Local Variables: +# mode: perl +# c-basic-indent: 4 +# indent-tabs-mode: nil +# End: diff --git a/lib/Danga/TimeoutSocket.pm b/lib/Danga/TimeoutSocket.pm new file mode 100644 index 0000000..fe74cd9 --- /dev/null +++ b/lib/Danga/TimeoutSocket.pm @@ -0,0 +1,49 @@ +# $Id: TimeoutSocket.pm,v 1.2 2005/02/02 20:44:35 msergeant Exp $ + +package Danga::TimeoutSocket; + +use base 'Danga::Socket'; +use fields qw(alive_time create_time); + +our $last_cleanup = 0; + +sub new { + my Danga::TimeoutSocket $self = shift; + my $sock = shift; + $self = fields::new($self) unless ref($self); + $self->SUPER::new($sock); + + my $now = time; + $self->{alive_time} = $self->{create_time} = $now; + + if ($now - 15 > $last_cleanup) { + $last_cleanup = $now; + _do_cleanup($now); + } + + return $self; +} + +sub _do_cleanup { + my $now = shift; + my $sf = __PACKAGE__->get_sock_ref; + + my %max_age; # classname -> max age (0 means forever) + my @to_close; + while (my $k = each %$sf) { + my Danga::TimeoutSocket $v = $sf->{$k}; + my $ref = ref $v; + next unless $v->isa('Danga::TimeoutSocket'); + unless (defined $max_age{$ref}) { + $max_age{$ref} = $ref->max_idle_time || 0; + } + next unless $max_age{$ref}; + if ($v->{alive_time} < $now - $max_age{$ref}) { + push @to_close, $v; + } + } + + $_->close("Timeout") foreach @to_close; +} + +1; From b5b3950ef9fb3a3dfa2fdb312d42031e44f38327 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 8 Mar 2005 22:52:23 +0000 Subject: [PATCH 003/106] Main initial work on poll server. git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@388 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 17 +- lib/Qpsmtpd/Plugin.pm | 4 + lib/Qpsmtpd/PollServer.pm | 332 +++++++++++++++++++++++++++++++ lib/Qpsmtpd/SelectServer.pm | 320 ------------------------------ qpsmtpd | 381 ++++++++++++++++++++++++++++++++++-- qpsmtpd-forkserver | 198 ------------------- qpsmtpd-server | 28 --- 7 files changed, 708 insertions(+), 572 deletions(-) create mode 100644 lib/Qpsmtpd/PollServer.pm delete mode 100644 lib/Qpsmtpd/SelectServer.pm delete mode 100755 qpsmtpd-forkserver delete mode 100755 qpsmtpd-server diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index e94220f..dfaf785 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -193,16 +193,16 @@ sub KQueueEventLoop { next; } - push @objs, [$pob, $fd, $filter, $flags, $fflags]; + DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", + $fd, ref($pob), $flags, time); + + push @objs, [$pob, $filter, $flags, $fflags]; } # TODO - prioritize the objects foreach (@objs) { - my ($pob, $fd, $filter, $flags, $fflags) = @$_; - - DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", - $fd, ref($pob), $flags, time); + my ($pob, $filter, $flags, $fflags) = @$_; $pob->event_read if $filter == IO::KQueue::EVFILT_READ() && !$pob->{closed}; $pob->event_write if $filter == IO::KQueue::EVFILT_WRITE() && !$pob->{closed}; @@ -236,6 +236,7 @@ sub EpollEventLoop { my $evcount; # get up to 1000 events, 1000ms timeout while ($evcount = epoll_wait($Epoll, 1000, 1000, \@events)) { + my @objs; EVENT: for ($i=0; $i<$evcount; $i++) { my $ev = $events[$i]; @@ -260,11 +261,17 @@ sub EpollEventLoop { DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", $ev->[0], ref($pob), $ev->[1], time); + push @objs, [$pob, $state]; + } + + foreach (@objs) { + my ($pob, $state) = @$_; $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; } + return unless PostEventLoop(); } diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 84482ce..25836a4 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -53,6 +53,10 @@ sub connection { shift->qp->connection; } +sub config { + shift->qp->config(@_); +} + sub spool_dir { shift->qp->spool_dir; } diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm new file mode 100644 index 0000000..73429a2 --- /dev/null +++ b/lib/Qpsmtpd/PollServer.pm @@ -0,0 +1,332 @@ +# $Id: Server.pm,v 1.10 2005/02/14 22:04:48 msergeant Exp $ + +package Qpsmtpd::PollServer; + +use base ('Danga::Client', 'Qpsmtpd::SMTP'); +# use fields required to be a subclass of Danga::Client. Have to include +# all fields used by Qpsmtpd.pm here too. +use fields qw( + input_sock + mode + header_lines + in_header + data_size + max_size + hooks + _auth + _commands + _config_cache + _connection + _transaction + _test_mode + _extras +); +use Qpsmtpd::Constants; +use Qpsmtpd::Auth; +use Qpsmtpd::Address; +use Danga::DNS; +use Mail::Header; +use POSIX qw(strftime); +use Socket qw(inet_aton AF_INET CRLF); + +sub input_sock { + my $self = shift; + @_ and $self->{input_sock} = shift; + $self->{input_sock} || $self; +} + +sub new { + my Qpsmtpd::PollServer $self = shift; + + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + $self->load_plugins; + return $self; +} + +sub reset_for_next_message { + my $self = shift; + $self->SUPER::reset_for_next_message(@_); + + $self->{_commands} = { + ehlo => 1, + helo => 1, + rset => 1, + mail => 1, + rcpt => 1, + data => 1, + help => 1, + vrfy => 1, + noop => 1, + quit => 1, + auth => 0, # disabled by default + }; + $self->{mode} = 'cmd'; + $self->{_extras} = {}; +} + +sub respond { + my $self = shift; + my ($code, @messages) = @_; + while (my $msg = shift @messages) { + my $line = $code . (@messages ? "-" : " ") . $msg; + $self->write("$line\r\n"); + } + return 1; +} + +sub process_line { + my $self = shift; + my $line = shift || return; + if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } + local $SIG{ALRM} = sub { + my ($pkg, $file, $line) = caller(); + die "ALARM: $pkg, $file, $line"; + }; + my $prev = alarm(2); # must process a command in < 2 seconds + eval { $self->_process_line($line) }; + alarm($prev); + if ($@) { + print STDERR "Error: $@\n"; + return $self->fault("command failed unexpectedly") if $self->{mode} eq 'cmd'; + return $self->fault("error processing data lines") if $self->{mode} eq 'data'; + return $self->fault("unknown error"); + } + return; +} + +sub _process_line { + my $self = shift; + my $line = shift; + + if ($self->{mode} eq 'cmd') { + $line =~ s/\r?\n//; + return $self->process_cmd($line); + } + elsif ($self->{mode} eq 'data') { + return $self->data_line($line); + } + else { + die "Unknown mode"; + } +} + +sub process_cmd { + my $self = shift; + my $line = shift; + my ($cmd, @params) = split(/ +/, $line); + my $meth = lc($cmd); + if (my $lookup = $self->{_commands}->{$meth} && $self->can($meth)) { + my $resp = eval { + $lookup->($self, @params); + }; + if ($@) { + my $error = $@; + chomp($error); + $self->log(LOGERROR, "Command Error: $error"); + return $self->fault("command '$cmd' failed unexpectedly"); + } + return $resp; + } + else { + # No such method - i.e. unrecognized command + my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd); + if ($rc == DENY) { + $self->respond(521, $msg); + $self->disconnect; + return; + } + elsif ($rc == DONE) { + return; # TODO - this isn't right. + } + else { + return $self->respond(500, "Unrecognized command"); + } + } +} + +sub disconnect { + my $self = shift; + $self->SUPER::disconnect(@_); + $self->close; +} + +sub start_conversation { + my $self = shift; + + my $conn = $self->connection; + # set remote_host, remote_ip and remote_port + my ($ip, $port) = split(':', $self->peer_addr_string); + $conn->remote_ip($ip); + $conn->remote_port($port); + Danga::DNS->new( + client => $self, + # NB: Setting remote_info to the same as remote_host + callback => sub { $conn->remote_info($conn->remote_host($_[0])) }, + host => $ip, + ); + + my ($rc, $msg) = $self->run_hooks("connect"); + if ($rc == DENY) { + $self->respond(550, ($msg || 'Connection from you denied, bye bye.')); + return $rc; + } + elsif ($rc == DENYSOFT) { + $self->respond(450, ($msg || 'Connection from you temporarily denied, bye bye.')); + return $rc; + } + elsif ($rc == DONE) { + $self->respond(220, $msg); + return $rc; + } + else { + $self->respond(220, $self->config('me') ." ESMTP qpsmtpd " + . $self->version ." ready; send us your mail, but not your spam."); + return DONE; + } +} + +sub data { + my $self = shift; + + my ($rc, $msg) = $self->run_hooks("data"); + if ($rc == DONE) { + return; + } + elsif ($rc == DENY) { + $self->respond(554, $msg || "Message denied"); + $self->reset_transaction(); + return; + } + elsif ($rc == DENYSOFT) { + $self->respond(451, $msg || "Message denied temporarily"); + $self->reset_transaction(); + return; + } + elsif ($rc == DENY_DISCONNECT) { + $self->respond(554, $msg || "Message denied"); + $self->disconnect; + return; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $self->respond(451, $msg || "Message denied temporarily"); + $self->disconnect; + return; + } + return $self->respond(503, "MAIL first") unless $self->transaction->sender; + return $self->respond(503, "RCPT first") unless $self->transaction->recipients; + + $self->{mode} = 'data'; + + $self->{header_lines} = []; + $self->{data_size} = 0; + $self->{in_header} = 1; + $self->{max_size} = ($self->config('databytes'))[0] || 0; # this should work in scalar context + + $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); + + return $self->respond(354, "go ahead"); +} + +sub data_line { + my $self = shift; + + my $line = shift; + + if ($line eq ".\r\n") { + # add received etc. + $self->{mode} = 'cmd'; + $self->end_of_data; + return; + } + + # Reject messages that have either bare LF or CR. rjkaes noticed a + # lot of spam that is malformed in the header. + if ($line eq ".\n" or $line eq ".\r") { + $self->respond(421, "See http://smtpd.develooper.com/barelf.html"); + $self->disconnect; + return; + } + + # add a transaction->blocked check back here when we have line by line plugin access... + unless (($self->{max_size} and $self->{data_size} > $self->{max_size})) { + $line =~ s/\r\n$/\n/; + $line =~ s/^\.\./\./; + + if ($self->{in_header} and $line =~ m/^\s*$/) { + # end of headers + $self->{in_header} = 0; + + # ... need to check that we don't reformat any of the received lines. + # + # 3.8.2 Received Lines in Gatewaying + # When forwarding a message into or out of the Internet environment, a + # gateway MUST prepend a Received: line, but it MUST NOT alter in any + # way a Received: line that is already in the header. + + my $header = Mail::Header->new($self->{header_lines}, + Modify => 0, MailFrom => "COERCE"); + $self->transaction->header($header); + + #$header->add("X-SMTPD", "qpsmtpd/".$self->version.", http://smtpd.develooper.com/"); + + # FIXME - call plugins to work on just the header here; can + # save us buffering the mail content. + } + + if ($self->{in_header}) { + push @{ $self->{header_lines} }, $line; + } + else { + $self->transaction->body_write($line); + } + + $self->{data_size} += length $line; + } + + return; +} + +sub end_of_data { + my $self = shift; + + #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); + + $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $size"); + + my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + + # only true if client authenticated + if ( defined $self->{_auth} and $self->{_auth} == OK ) { + $header->add("X-Qpsmtpd-Auth","True"); + } + + $self->transaction->header->add("Received", "from ".$self->connection->remote_info + ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip + . ")\n by ".$self->config('me')." (qpsmtpd/".$self->version + .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), + 0); + + return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size}; + + ($rc, $msg) = $self->run_hooks("data_post"); + if ($rc == DONE) { + return; + } + elsif ($rc == DENY) { + $self->respond(552, $msg || "Message denied"); + } + elsif ($rc == DENYSOFT) { + $self->respond(452, $msg || "Message denied temporarily"); + } + else { + $self->queue($self->transaction); + } + + # DATA is always the end of a "transaction" + $self->reset_transaction; + return; +} + +1; + diff --git a/lib/Qpsmtpd/SelectServer.pm b/lib/Qpsmtpd/SelectServer.pm deleted file mode 100644 index 07e5c56..0000000 --- a/lib/Qpsmtpd/SelectServer.pm +++ /dev/null @@ -1,320 +0,0 @@ -package Qpsmtpd::SelectServer; -use Qpsmtpd::SMTP; -use Qpsmtpd::Constants; -use IO::Socket; -use IO::Select; -use POSIX qw(strftime); -use Socket qw(CRLF); -use Fcntl; -use Tie::RefHash; -use Net::DNS; - -@ISA = qw(Qpsmtpd::SMTP); -use strict; - -our %inbuffer = (); -our %outbuffer = (); -our %ready = (); -our %lookup = (); -our %qp = (); -our %indata = (); - -tie %ready, 'Tie::RefHash'; -my $server; -my $select; - -our $QUIT = 0; - -$SIG{INT} = $SIG{TERM} = sub { $QUIT++ }; - -sub log { - my ($self, $trace, @log) = @_; - my $level = Qpsmtpd::TRACE_LEVEL(); - $level = $self->init_logger unless defined $level; - warn join(" ", fileno($self->client), @log), "\n" - if $trace <= $level; -} - -sub main { - my $class = shift; - my %opts = (LocalPort => 25, Reuse => 1, Listen => SOMAXCONN, @_); - $server = IO::Socket::INET->new(%opts) or die "Server: $@"; - print "Listening on $opts{LocalPort}\n"; - - nonblock($server); - - $select = IO::Select->new($server); - my $res = Net::DNS::Resolver->new; - - # TODO - make this more graceful - let all current SMTP sessions finish - # before quitting! - while (!$QUIT) { - foreach my $client ($select->can_read(1)) { - #print "Reading $client\n"; - if ($client == $server) { - my $client_addr; - $client = $server->accept(); - next unless $client; - my $ip = $client->peerhost; - my $bgsock = $res->bgsend($ip); - $select->add($bgsock); - $lookup{$bgsock} = $client; - } - elsif (my $qpclient = $lookup{$client}) { - my $packet = $res->bgread($client); - my $ip = $qpclient->peerhost; - my $hostname = $ip; - if ($packet) { - foreach my $rr ($packet->answer) { - if ($rr->type eq 'PTR') { - $hostname = $rr->rdatastr; - } - } - } - # $packet->print; - $select->remove($client); - delete($lookup{$client}); - my $qp = Qpsmtpd::SelectServer->new(); - $qp->client($qpclient); - $qp{$qpclient} = $qp; - $qp->log(LOGINFO, "Connection number " . keys(%qp)); - $inbuffer{$qpclient} = ''; - $outbuffer{$qpclient} = ''; - $ready{$qpclient} = []; - $qp->start_connection($ip, $hostname); - $qp->load_plugins; - my $rc = $qp->start_conversation; - if ($rc != DONE) { - close($client); - next; - } - $select->add($qpclient); - nonblock($qpclient); - } - else { - my $data = ''; - my $rv = $client->recv($data, POSIX::BUFSIZ(), 0); - - unless (defined($rv) && length($data)) { - freeclient($client) - unless ($! == POSIX::EWOULDBLOCK() || - $! == POSIX::EINPROGRESS() || - $! == POSIX::EINTR()); - next; - } - $inbuffer{$client} .= $data; - - while ($inbuffer{$client} =~ s/^([^\r\n]*)\r?\n//) { - #print "<$1\n"; - push @{$ready{$client}}, $1; - } - } - } - - #print "Processing...\n"; - foreach my $client (keys %ready) { - my $qp = $qp{$client}; - #print "Processing $client = $qp\n"; - foreach my $req (@{$ready{$client}}) { - if ($indata{$client}) { - $qp->data_line($req . CRLF); - } - else { - $qp->log(LOGINFO, "dispatching $req"); - defined $qp->dispatch(split / +/, $req) - or $qp->respond(502, "command unrecognized: '$req'"); - } - } - delete $ready{$client}; - } - - #print "Writing...\n"; - foreach my $client ($select->can_write(1)) { - next unless $outbuffer{$client}; - #print "Writing to $client\n"; - - my $rv = $client->send($outbuffer{$client}, 0); - unless (defined($rv)) { - warn("I was told to write, but I can't: $!\n"); - next; - } - if ($rv == length($outbuffer{$client}) || - $! == POSIX::EWOULDBLOCK()) - { - #print "Sent all, or EWOULDBLOCK\n"; - if ($qp{$client}->{__quitting}) { - freeclient($client); - next; - } - substr($outbuffer{$client}, 0, $rv, ''); - delete($outbuffer{$client}) unless length($outbuffer{$client}); - } - else { - print "Error: $!\n"; - # Couldn't write all the data, and it wasn't because - # it would have blocked. Shut down and move on. - freeclient($client); - next; - } - } - } -} - -sub freeclient { - my $client = shift; - #print "Freeing client: $client\n"; - delete $inbuffer{$client}; - delete $outbuffer{$client}; - delete $ready{$client}; - delete $qp{$client}; - $select->remove($client); - close($client); -} - -sub start_connection { - my $self = shift; - my $remote_ip = shift; - my $remote_host = shift; - - $self->log(LOGNOTICE, "Connection from $remote_host [$remote_ip]"); - my $remote_info = 'NOINFO'; - - # if the local dns resolver doesn't filter it out we might get - # ansi escape characters that could make a ps axw do "funny" - # things. So to be safe, cut them out. - $remote_host =~ tr/a-zA-Z\.\-0-9//cd; - - $self->SUPER::connection->start(remote_info => $remote_info, - remote_ip => $remote_ip, - remote_host => $remote_host, - @_); -} - -sub client { - my $self = shift; - @_ and $self->{_client} = shift; - $self->{_client}; -} - -sub nonblock { - my $socket = shift; - my $flags = fcntl($socket, F_GETFL, 0) - or die "Can't get flags for socket: $!"; - fcntl($socket, F_SETFL, $flags | O_NONBLOCK) - or die "Can't set flags for socket: $!"; -} - -sub read_input { - my $self = shift; - die "read_input is disabled in SelectServer"; -} - -sub respond { - my ($self, $code, @messages) = @_; - my $client = $self->client || die "No client!"; - while (my $msg = shift @messages) { - my $line = $code . (@messages?"-":" ").$msg; - $self->log(LOGINFO, ">$line"); - $outbuffer{$client} .= "$line\r\n"; - } - return 1; -} - -sub disconnect { - my $self = shift; - #print "Disconnecting\n"; - $self->{__quitting} = 1; - $self->SUPER::disconnect(@_); -} - -sub data { - my $self = shift; - $self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender; - $self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients; - $self->respond(354, "go ahead"); - $indata{$self->client()} = 1; - $self->{__buffer} = ''; - $self->{__size} = 0; - $self->{__blocked} = ""; - $self->{__in_header} = 1; - $self->{__complete} = 0; - $self->{__max_size} = $self->config('databytes') || 0; -} - -sub data_line { - my $self = shift; - local $_ = shift; - - if ($_ eq ".\r\n") { - $self->log(LOGDEBUG, "max_size: $self->{__max_size} / size: $self->{__size}"); - delete $indata{$self->client()}; - - my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; - - if (!$self->transaction->header) { - $self->transaction->header(Mail::Header->new(Modify => 0, MailFrom => "COERCE")); - } - $self->transaction->header->add("Received", "from ".$self->connection->remote_info - ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip - . ") by ".$self->config('me')." (qpsmtpd/".$self->version - .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), - 0); - - #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked); - $self->respond(552, "Message too big!"),return 1 if $self->{__max_size} and $self->{__size} > $self->{__max_size}; - - my ($rc, $msg) = $self->run_hooks("data_post"); - if ($rc == DONE) { - return 1; - } - elsif ($rc == DENY) { - $self->respond(552, $msg || "Message denied"); - } - elsif ($rc == DENYSOFT) { - $self->respond(452, $msg || "Message denied temporarily"); - } - else { - $self->queue($self->transaction); - } - - # DATA is always the end of a "transaction" - return $self->reset_transaction; - } - elsif ($_ eq ".\n") { - $self->respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html"); - $self->{__quitting} = 1; - return; - } - - # add a transaction->blocked check back here when we have line by line plugin access... - unless (($self->{__max_size} and $self->{__size} > $self->{__max_size})) { - s/\r\n$/\n/; - s/^\.\./\./; - if ($self->{__in_header} and m/^\s*$/) { - $self->{__in_header} = 0; - my @header = split /\n/, $self->{__buffer}; - - # ... need to check that we don't reformat any of the received lines. - # - # 3.8.2 Received Lines in Gatewaying - # When forwarding a message into or out of the Internet environment, a - # gateway MUST prepend a Received: line, but it MUST NOT alter in any - # way a Received: line that is already in the header. - - my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); - $header->extract(\@header); - $self->transaction->header($header); - $self->{__buffer} = ""; - } - - if ($self->{__in_header}) { - $self->{__buffer} .= $_; - } - else { - $self->transaction->body_write($_); - } - $self->{__size} += length $_; - } -} - -1; diff --git a/qpsmtpd b/qpsmtpd index 254458e..5296717 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -1,30 +1,369 @@ -#!/usr/bin/perl -Tw -# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details. -# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/ -# -# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html) -# or inetd if you're into that sort of thing -# -# -# For more information see http://develooper.com/code/qpsmtpd/ -# -# +#!/usr/bin/perl -w + +use lib "./lib"; +BEGIN { + delete $ENV{ENV}; + delete $ENV{BASH_ENV}; + $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin:/usr/local/bin'; +} -use lib 'lib'; -use Qpsmtpd::TcpServer; use strict; -$| = 1; +use vars qw($DEBUG); +use FindBin; +use lib "$FindBin::Bin/lib"; +use Danga::Socket; +use Danga::Client; +use Qpsmtpd::PollServer; +use Qpsmtpd::Constants; +use IO::Socket; +use Carp; +use POSIX qw(WNOHANG); +use Getopt::Long; -delete $ENV{ENV}; -$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; +$|++; -my $qpsmtpd = Qpsmtpd::TcpServer->new(); -$qpsmtpd->start_connection(); -$qpsmtpd->run(); +# For debugging +# $SIG{USR1} = sub { Carp::confess("USR1") }; -__END__ +use Socket qw(IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); +$SIG{'PIPE'} = "IGNORE"; # handled manually +$DEBUG = 0; +my $PORT = 2525; +my $LOCALADDR = '0.0.0.0'; +my $LineMode = 0; +my $PROCS = 1; +my $MAXCONN = 15; # max simultaneous connections +my $USER = 'smtpd'; # user to suid to +my $MAXCONNIP = 5; # max simultaneous connections from one IP +sub help { + print < \$PORT, + 'l|listen-address=s' => \$LOCALADDR, + 'j|procs=i' => \$PROCS, + 'd|debug+' => \$DEBUG, + 'f|forkmode' => \$LineMode, + 'c|limit-connections=i' => \$MAXCONN, + 'm|max-from-ip=i' => \$MAXCONNIP, + 'u|user=s' => \$USER, + 'h|help' => \&help, +) || help(); + +# detaint the commandline +if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &help } +if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help } +if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help } +if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &help } +if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help } + +$PROCS = 1 if $LineMode; +# This is a bit of a hack, but we get to approximate MAXCONN stuff when we +# have multiple children listening on the same socket. +$MAXCONN /= $PROCS; +$MAXCONNIP /= $PROCS; + +Danga::Socket::init_poller(); + +my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : + $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()"); + +my $server; + +# Code for inetd/tcpserver mode +if ($ENV{REMOTE_HOST}) { + run_as_inetd(); + exit(0); +} + +my %childstatus = (); + +run_as_server(); +exit(0); + +sub _fork { + my $pid = fork; + if (!defined($pid)) { die "Cannot fork: $!" } + return $pid if $pid; + + # Fixup Net::DNS randomness after fork + srand($$ ^ time); + + local $^W; + delete $INC{'Net/DNS/Header.pm'}; + require Net::DNS::Header; + + # cope with different versions of Net::DNS + eval { + $Net::DNS::Resolver::global{id} = 1; + $Net::DNS::Resolver::global{id} = int(rand(Net::DNS::Resolver::MAX_ID())); + # print "Next DNS ID: $Net::DNS::Resolver::global{id}\n"; + }; + if ($@) { + # print "Next DNS ID: " . Net::DNS::Header::nextid() . "\n"; + } + + # Fixup lost kqueue after fork + $Danga::Socket::HaveKQueue = undef; + Danga::Socket::init_poller(); +} + +sub spawn_child { + _fork and return; + + $SIG{CHLD} = "DEFAULT"; + + Qpsmtpd::PollServer->OtherFds(fileno($server) => \&accept_handler); + Qpsmtpd::PollServer->EventLoop(); + exit; +} + +sub sig_chld { + $SIG{CHLD} = 'IGNORE'; + while ( (my $child = waitpid(-1,WNOHANG)) > 0) { + last unless $child > 0; + print "child $child died\n"; + delete $childstatus{$child}; + } + return if $LineMode; + # restart a new child if in poll server mode + spawn_child(); + $SIG{CHLD} = \&sig_chld; +} + +sub HUNTSMAN { + $SIG{CHLD} = 'DEFAULT'; + kill 'INT' => keys %childstatus; + exit(0); +} + +sub run_as_inetd { + $LineMode = 1; + + my $insock = IO::Handle->new_from_fd(0, "r"); + IO::Handle::blocking($insock, 0); + + my $outsock = IO::Handle->new_from_fd(1, "w"); + IO::Handle::blocking($outsock, 0); + + my $client = Danga::Client->new($insock); + + my $out = Qpsmtpd::PollServer->new($outsock); + $out->load_plugins; + $out->init_logger; + $out->input_sock($client); + my $rc = $out->start_conversation; + if ($rc != DONE) { + return; + } + + $client->watch_read(1); + while (1) { + my $line = $client->get_line; + last if !defined($line); + my $output = $out->process_line($line); + $out->write($output) if $output; + $client->watch_read(1); + } +} + +sub run_as_server { + # establish SERVER socket, bind and listen. + $server = IO::Socket::INET->new(LocalPort => $PORT, + LocalAddr => $LOCALADDR, + Type => SOCK_STREAM, + Proto => IPPROTO_TCP, + Blocking => 0, + Reuse => 1, + Listen => 10 ) + or die "Error creating server $LOCALADDR:$PORT : $@\n"; + + IO::Handle::blocking($server, 0); + binmode($server, ':raw'); + + # Drop priviledges + my (undef, undef, $quid, $qgid) = getpwnam $USER or + die "unable to determine uid/gid for $USER\n"; + $) = ""; + POSIX::setgid($qgid) or + die "unable to change gid: $!\n"; + POSIX::setuid($quid) or + die "unable to change uid: $!\n"; + $> = $quid; + + ::log(LOGINFO, 'Running as user '. + (getpwuid($>) || $>) . + ', group '. + (getgrgid($)) || $))); + + # Load plugins here + my $plugin_loader = Qpsmtpd::SMTP->new(); + $plugin_loader->load_plugins; + + if ($PROCS > 1) { + $SIG{'CHLD'} = \&sig_chld; + my @kids; + for (1..$PROCS) { + push @kids, spawn_child(); + } + $SIG{INT} = $SIG{TERM} = sub { $SIG{CHLD} = "IGNORE"; kill 2 => @kids; exit }; + ::log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL"); + sleep while (1); + } + else { + if ($LineMode) { + $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; + } + ::log(LOGDEBUG, "Listening on $PORT with single process $POLL" . + ($LineMode ? " (forking server)" : "")); + Qpsmtpd::PollServer->OtherFds(fileno($server) => \&accept_handler); + while (1) { + Qpsmtpd::PollServer->EventLoop(); + } + exit; + } + +} + +# Accept a new connection +sub accept_handler { + my $running = scalar keys %childstatus; + while ($running >= $MAXCONN) { + ::log(LOGINFO,"Too many connections: $running >= $MAXCONN."); + return; + } + + my $csock = $server->accept(); + if (!$csock) { + # warn("accept() failed: $!"); + } + return unless $csock; + binmode($csock, ':raw'); + + printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock)) + if $DEBUG; + + IO::Handle::blocking($csock, 0); + setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; + + if (!$LineMode) { + # multiplex mode + my $client = Qpsmtpd::PollServer->new($csock); + my $rem_ip = $client->peer_ip_string; + + if ($MAXCONNIP) { + my $num_conn = 1; # seed with current value + + # If we for-loop directly over values %childstatus, a SIGCHLD + # can call REAPER and slip $rip out from under us. Causes + # "Use of freed value in iteration" under perl 5.8.4. + my $descriptors = Danga::Client->DescriptorMap; + my @obj = values %$descriptors; + foreach my $obj (@obj) { + local $^W; + # This is a bit of a slow way to do this. Wish I could cache the method call. + ++$num_conn if ($obj->peer_ip_string eq $rem_ip); + } + + if ($num_conn > $MAXCONNIP) { + ::log(LOGINFO,"Too many connections from $rem_ip: " + ."$num_conn > $MAXCONNIP. Denying connection."); + $client->write("451 Sorry, too many connections from $rem_ip, try again later\r\n"); + $client->close; + return; + } + } + + my $rc = $client->start_conversation; + if ($rc != DONE) { + $client->close; + return; + } + $client->watch_read(1); + return; + } + + # fork-per-connection mode + my $rem_ip = $csock->sockhost(); + + if ($MAXCONNIP) { + my $num_conn = 1; # seed with current value + + my @rip = values %childstatus; + foreach my $rip (@rip) { + ++$num_conn if (defined $rip && $rip eq $rem_ip); + } + + if ($num_conn > $MAXCONNIP) { + ::log(LOGINFO,"Too many connections from $rem_ip: " + ."$num_conn > $MAXCONNIP. Denying connection."); + print $csock "451 Sorry, too many connections from $rem_ip, try again later\r\n"; + close $csock; + return; + } + } + + if (my $pid = _fork) { + $childstatus{$pid} = $rem_ip; + return $csock->close(); + } + + $server->close(); # make sure the child doesn't accept() new connections + + $SIG{$_} = 'DEFAULT' for keys %SIG; + + my $client = Qpsmtpd::PollServer->new($csock); + my $rc = $client->start_conversation; + if ($rc != DONE) { + $client->close; + exit; + } + $client->watch_read(1); + + while (1) { + my $line = $client->get_line; + last if !defined($line); + my $resp = $client->process_line($line); + # if ($resp) { print "S: $_\n" for split(/\n/, $resp) } + $client->write($resp) if $resp; + $client->watch_read(1); + } + + ::log(LOGDEBUG, "Finished with child %d.\n", fileno($csock)) + if $DEBUG; + $client->close(); + + exit; +} + +######################################################################## + +sub log { + my ($level,$message) = @_; + # $level not used yet. this is reimplemented from elsewhere anyway + warn("$$ $message\n"); +} -1; diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver deleted file mode 100755 index a9e8ab6..0000000 --- a/qpsmtpd-forkserver +++ /dev/null @@ -1,198 +0,0 @@ -#!/usr/bin/perl -Tw -# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details. -# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/ -# -# For more information see http://develooper.com/code/qpsmtpd/ -# -# - -use lib 'lib'; -use Qpsmtpd::TcpServer; -use Qpsmtpd::Constants; -use IO::Socket; -use Socket; -use Getopt::Long; -use POSIX qw(:sys_wait_h :errno_h :signal_h); -use strict; -$| = 1; - -# Configuration -my $MAXCONN = 15; # max simultaneous connections -my $PORT = 2525; # port number -my $LOCALADDR = '0.0.0.0'; # ip address to bind to -my $USER = 'smtpd'; # user to suid to -my $MAXCONNIP = 5; # max simultaneous connections from one IP - -sub usage { - print <<"EOT"; -usage: qpsmtpd-forkserver [ options ] - -l, --listen-address addr : listen on a specific address; default 0.0.0.0 - -p, --port P : listen on a specific port; default 2525 - -c, --limit-connections N : limit concurrent connections to N; default 15 - -u, --user U : run as a particular user (defualt 'smtpd') - -m, --max-from-ip M : limit connections from a single IP; default 5 -EOT - exit 0; -} - -GetOptions('h|help' => \&usage, - 'l|listen-address=s' => \$LOCALADDR, - 'c|limit-connections=i' => \$MAXCONN, - 'm|max-from-ip=i' => \$MAXCONNIP, - 'p|port=i' => \$PORT, - 'u|user=s' => \$USER) || &usage; - -# detaint the commandline -if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &usage } -if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &usage } -if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &usage } -if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &usage } - -delete $ENV{ENV}; -$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; - -my %childstatus = (); - -sub REAPER { - $SIG{CHLD} = \&REAPER; - while ( defined(my $chld = waitpid(-1, WNOHANG)) ){ - last unless $chld > 0; - warn("$$ cleaning up after $chld\n"); - delete $childstatus{$chld}; - } -} - -sub HUNTSMAN { - $SIG{CHLD} = 'DEFAULT'; - kill 'INT' => keys %childstatus; - exit(0); -} - -$SIG{CHLD} = \&REAPER; -$SIG{INT} = \&HUNTSMAN; -$SIG{TERM} = \&HUNTSMAN; - -# establish SERVER socket, bind and listen. -my $server = IO::Socket::INET->new(LocalPort => $PORT, - LocalAddr => $LOCALADDR, - Proto => 'tcp', - Reuse => 1, - Listen => SOMAXCONN ) - or die "Creating TCP socket $LOCALADDR:$PORT: $!\n"; -::log(LOGINFO,"Listening on port $PORT"); - -# Drop priviledges -my (undef, undef, $quid, $qgid) = getpwnam $USER or - die "unable to determine uid/gid for $USER\n"; -$) = ""; -POSIX::setgid($qgid) or - die "unable to change gid: $!\n"; -POSIX::setuid($quid) or - die "unable to change uid: $!\n"; -$> = $quid; - -::log(LOGINFO, 'Running as user '. - (getpwuid($>) || $>) . - ', group '. - (getgrgid($)) || $))); - -# Load plugins here -my $plugin_loader = Qpsmtpd::TcpServer->new(); -$plugin_loader->load_plugins; - - -while (1) { - my $running = scalar keys %childstatus; - while ($running >= $MAXCONN) { - ::log(LOGINFO,"Too many connections: $running >= $MAXCONN. Waiting one second."); - sleep(1) ; - $running = scalar keys %childstatus; - } - my $hisaddr = accept(my $client, $server); - if (!$hisaddr) { - # possible something condition... - next; - } - my ($port, $iaddr) = sockaddr_in($hisaddr); - if ($MAXCONNIP) { - my $num_conn = 1; # seed with current value - - # If we for-loop directly over values %childstatus, a SIGCHLD - # can call REAPER and slip $rip out from under us. Causes - # "Use of freed value in iteration" under perl 5.8.4. - my @rip = values %childstatus; - foreach my $rip (@rip) { - ++$num_conn if (defined $rip && $rip eq $iaddr); - } - - if ($num_conn > $MAXCONNIP) { - my $rem_ip = inet_ntoa($iaddr); - ::log(LOGINFO,"Too many connections from $rem_ip: " - ."$num_conn > $MAXCONNIP. Denying connection."); - $client->autoflush(1); - print $client "451 Sorry, too many connections from $rem_ip, try again later\r\n"; - close $client; - next; - } - } - my $pid = fork; - if ($pid) { - # parent - $childstatus{$pid} = $iaddr; # add to table - # $childstatus{$pid} = 1; # add to table - $running++; - close($client); - next; - } - die "fork: $!" unless defined $pid; # failure - # otherwise child - - # all children should have different seeds, to prevent conflicts - srand( time ^ ($$ + ($$ << 15)) ); - - close($server); - - $SIG{$_} = 'DEFAULT' for keys %SIG; - $SIG{ALRM} = sub { - print $client "421 Connection Timed Out\n"; - ::log(LOGINFO, "Connection Timed Out"); - exit; }; - - my $localsockaddr = getsockname($client); - my ($lport, $laddr) = sockaddr_in($localsockaddr); - $ENV{TCPLOCALIP} = inet_ntoa($laddr); - # my ($port, $iaddr) = sockaddr_in($hisaddr); - $ENV{TCPREMOTEIP} = inet_ntoa($iaddr); - $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown"; - - # don't do this! - #$0 = "qpsmtpd-forkserver: $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"; - - ::log(LOGINFO, "Accepted connection $running/$MAXCONN from $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"); - - # dup to STDIN/STDOUT - POSIX::dup2(fileno($client), 0); - POSIX::dup2(fileno($client), 1); - - my $qpsmtpd = Qpsmtpd::TcpServer->new(); - $qpsmtpd->start_connection - ( - local_ip => $ENV{TCPLOCALIP}, - local_port => $lport, - remote_ip => $ENV{TCPREMOTEIP}, - remote_port => $port, - ); - $qpsmtpd->run(); - - exit; # child leaves -} - -sub log { - my ($level,$message) = @_; - # $level not used yet. this is reimplemented from elsewhere anyway - warn("$$ $message\n"); -} - -__END__ - -1; diff --git a/qpsmtpd-server b/qpsmtpd-server deleted file mode 100755 index 248c472..0000000 --- a/qpsmtpd-server +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/perl -Tw -# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details. -# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/ -# -# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html) -# or inetd if you're into that sort of thing -# -# -# For more information see http://develooper.com/code/qpsmtpd/ -# -# - -use lib 'lib'; -use Qpsmtpd::SelectServer; -use strict; -$| = 1; - -delete $ENV{ENV}; -$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; - -Qpsmtpd::SelectServer->main(); - -__END__ - - - - -1; From 6495f41bb2d01a13261730bfd2e7ad19ca05d24e Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 8 Mar 2005 22:58:09 +0000 Subject: [PATCH 004/106] High perf versions of these plugins git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@389 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 28 ++--- plugins/dnsbl | 174 ++++++++-------------------- plugins/require_resolvable_fromhost | 96 ++++++++------- plugins/rhsbl | 117 ++++++------------- 4 files changed, 150 insertions(+), 265 deletions(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index b44192b..f8cd5a1 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -53,14 +53,14 @@ sub register { my ($self, $qp, @args) = @_; if (@args % 2) { - $self->log(LOGERROR, "Unrecognized/mismatched arguments"); - return undef; + $self->log(LOGERROR, "Unrecognized/mismatched arguments"); + return undef; } $self->{_args} = { - 'wait' => 1, - 'action' => 'denysoft', - 'defer-reject' => 0, - @args, + 'wait' => 1, + 'action' => 'denysoft', + 'defer-reject' => 0, + @args, }; $self->register_hook('connect', 'connect_handler'); $self->register_hook('mail', 'mail_handler') @@ -70,17 +70,11 @@ sub register { sub connect_handler { my ($self, $transaction) = @_; - my $in = new IO::Select; - my $ip = $self->qp->connection->remote_ip; - - return DECLINED - if ($self->qp->connection->notes('whitelistclient')); - - $in->add(\*STDIN) || return DECLINED; - if ($in->can_read($self->{_args}->{'wait'})) { - $self->log(LOGNOTICE, "remote host started talking before we said hello [$ip]"); + + if ($self->argh->can_read($self->{_args}->{'wait'})) { + $self->log(LOGNOTICE, 'remote host started talking before we said hello'); if ($self->{_args}->{'defer-reject'}) { - $self->qp->connection->notes('earlytalker', 1); + $self->connection->notes('earlytalker', 1); } else { my $msg = 'Connecting host started transmitting before SMTP greeting'; return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; @@ -96,7 +90,7 @@ sub mail_handler { my ($self, $txn) = @_; my $msg = 'Connecting host started transmitting before SMTP greeting'; - return DECLINED unless $self->qp->connection->notes('earlytalker'); + return DECLINED unless $self->connection->notes('earlytalker'); return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; return DECLINED; diff --git a/plugins/dnsbl b/plugins/dnsbl index 9c4ec80..a89beee 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -1,14 +1,17 @@ +#!/usr/bin/perl -w + +use Danga::DNS; + sub register { - my ($self, $qp) = @_; + my ($self) = @_; $self->register_hook("connect", "connect_handler"); $self->register_hook("rcpt", "rcpt_handler"); - $self->register_hook("disconnect", "disconnect_handler"); } sub connect_handler { my ($self, $transaction) = @_; - my $remote_ip = $self->qp->connection->remote_ip; + my $remote_ip = $self->connection->remote_ip; # perform RBLSMTPD checks to mimic Dan Bernstein's rblsmtpd if (defined($ENV{'RBLSMTPD'})) { @@ -23,123 +26,66 @@ sub connect_handler { $self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip"); } - my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->qp->config('dnsbl_allow'); + my $allow = grep { s/\.?$/./; $_ eq substr($remote_ip . '.', 0, length $_) } $self->config('dnsbl_allow'); return DECLINED if $allow; - my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); + my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->config('dnsbl_zones'); return DECLINED unless %dnsbl_zones; my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); - # we should queue these lookups in the background and just fetch the - # results in the first rcpt handler ... oh well. - - my $res = new Net::DNS::Resolver; - $res->tcp_timeout(30); - $res->udp_timeout(30); - - my $sel = IO::Select->new(); - for my $dnsbl (keys %dnsbl_zones) { # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp if (defined($dnsbl_zones{$dnsbl})) { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background"); - $sel->add($res->bgsend("$reversed_ip.$dnsbl")); + Danga::DNS->new( + callback => sub { $self->process_a_result($dnsbl_zones{$dnsbl}, @_) }, + host => "$reversed_ip.$dnsbl", + type => 'A', + client => $self->argh->input_sock, + ); } else { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background"); - $sel->add($res->bgsend("$reversed_ip.$dnsbl", "TXT")); + Danga::DNS->new( + callback => sub { $self->process_txt_result(@_) }, + host => "$reversed_ip.$dnsbl", + type => 'TXT', + client => $self->argh->input_sock, + ); } } - $self->qp->connection->notes('dnsbl_sockets', $sel); - return DECLINED; } -sub process_sockets { - my ($self) = @_; - - my $conn = $self->qp->connection; - - return $conn->notes('dnsbl') - if $conn->notes('dnsbl'); - - my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones'); - - my $res = new Net::DNS::Resolver; - $res->tcp_timeout(30); - $res->udp_timeout(30); - - my $sel = $conn->notes('dnsbl_sockets') or return ""; - my $remote_ip = $self->qp->connection->remote_ip; - - my $result; - - $self->log(LOGDEBUG, "waiting for dnsbl dns"); - - # don't wait more than 8 seconds here - my @ready = $sel->can_read(8); - - $self->log(LOGDEBUG, "DONE waiting for dnsbl dns, got " , scalar @ready, " answers ...") ; - return '' unless @ready; - - for my $socket (@ready) { - my $query = $res->bgread($socket); - $sel->remove($socket); - undef $socket; - - my $dnsbl; - - if ($query) { - my $a_record = 0; - foreach my $rr ($query->answer) { - $a_record = 1 if $rr->type eq "A"; - my $name = $rr->name; - ($dnsbl) = ($name =~ m/(?:\d+\.){4}(.*)/) unless $dnsbl; - $dnsbl = $name unless $dnsbl; - $self->log(LOGDEBUG, "name ", $rr->name); - next unless $rr->type eq "TXT"; - $self->log(LOGDEBUG, "got txt record"); - $result = $rr->txtdata and last; - } - #$a_record and $result = "Blocked by $dnsbl"; - - if ($a_record) { - if (defined $dnsbl_zones{$dnsbl}) { - $result = $dnsbl_zones{$dnsbl}; - #$result =~ s/%IP%/$ENV{'TCPREMOTEIP'}/g; - $result =~ s/%IP%/$remote_ip/g; - } else { - # shouldn't get here? - $result = "Blocked by $dnsbl"; - } - } +sub process_a_result { + my $self = shift; + my ($template, $result, $query) = @_; + + warn("Result for A $query: $result\n"); + if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { + # NXDOMAIN or ERROR possibly... + return; } - else { - $self->log(LOGERROR, "$dnsbl query failed: ", $res->errorstring) - unless $res->errorstring eq "NXDOMAIN"; + + my $ip = $self->connection->remote_ip; + $template =~ s/%IP%/$ip/g; + my $conn = $self->connection; + $conn->notes('dnsbl', $template) unless $conn->notes('dnsbl'); +} + +sub process_txt_result { + my $self = shift; + my ($result, $query) = @_; + + warn("Result for TXT $query: $result\n"); + if ($result !~ /[a-z]/) { + # NXDOMAIN or ERROR probably... + return; } - - if ($result) { - #kill any other pending I/O - $conn->notes('dnsbl_sockets', undef); - $result = join("\n", $self->qp->config('dnsbl_rejectmsg'), $result); - return $conn->notes('dnsbl', $result); - } - } - - if ($sel->count) { - # loop around if we have dns blacklists left to see results from - return $self->process_sockets(); - } - - # er, the following code doesn't make much sense anymore... - - # if there was more to read; then forget it - $conn->notes('dnsbl_sockets', undef); - - return $conn->notes('dnsbl', $result); - + + my $conn = $self->connection; + $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl'); } sub rcpt_handler { @@ -148,33 +94,13 @@ sub rcpt_handler { # RBLSMTPD being non-empty means it contains the failure message to return if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { my $result = $ENV{'RBLSMTPD'}; - my $remote_ip = $self->qp->connection->remote_ip; + my $remote_ip = $self->connection->remote_ip; $result =~ s/%IP%/$remote_ip/g; - return (DENY, join(" ", $self->qp->config('dnsbl_rejectmsg'), $result)); + return (DENY, join(" ", $self->config('dnsbl_rejectmsg'), $result)); } - my $note = $self->process_sockets; - my $whitelist = $self->qp->connection->notes('whitelisthost'); - if ( $note ) { - if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) { - $self->log(2, "Don't blacklist special account: ".$rcpt->user); - } - elsif ( $whitelist ) { - $self->log(2, "Whitelist overrode blacklist: $whitelist"); - } - else { - return (DENY, $note); - } - } - return DECLINED; - -} - -sub disconnect_handler { - my ($self, $transaction) = @_; - - $self->qp->connection->notes('dnsbl_sockets', undef); - + my $note = $self->connection->notes('dnsbl'); + return (DENY, $note) if $note; return DECLINED; } diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index c469533..48b7a95 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -1,51 +1,67 @@ -use Net::DNS qw(mx); +#!/usr/bin/perl + +use Danga::DNS; sub register { - my ($self, $qp) = @_; - $self->register_hook("mail", "mail_handler"); + my ($self) = @_; + $self->register_hook("mail", "mail_handler"); + $self->register_hook("rcpt", "rcpt_handler"); } sub mail_handler { - my ($self, $transaction, $sender) = @_; - - return DECLINED - if ($self->qp->connection->notes('whitelistclient')); - - $sender->format ne "<>" - and $self->qp->config("require_resolvable_fromhost") - and !$self->check_dns($sender->host) - and return (DENYSOFT, - ($sender->host - ? "Could not resolve ". $sender->host - : "FQDN required in the envelope sender")); - - return DECLINED; - + my ($self, $transaction, $sender) = @_; + + $sender->format ne "<>" and $self->check_dns($sender->host); + + return DECLINED; } sub check_dns { - my ($self, $host) = @_; - - # for stuff where we can't even parse a hostname out of the address - return 0 unless $host; - - return 1 if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; - - my $res = new Net::DNS::Resolver; - $res->tcp_timeout(30); - $res->udp_timeout(30); - return 1 if mx($res, $host); - my $query = $res->search($host); - if ($query) { - foreach my $rr ($query->answer) { - return 1 if $rr->type eq "A" or $rr->type eq "MX"; - } - } - else { - $self->log(LOGWARN, "$$ query for $host failed: ", $res->errorstring) - unless $res->errorstring eq "NXDOMAIN"; - } - return 0; + my ($self, $host) = @_; + + # for stuff where we can't even parse a hostname out of the address + return unless $host; + + return $self->transaction->notes('resolvable', 1) + if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; + + Danga::DNS->new( + callback => sub { $self->dns_result(@_) }, + host => $host, + type => "MX", + client => $self->argh->input_sock, + ); + Danga::DNS->new( + callback => sub { $self->dns_result(@_) }, + host => $host, + client => $self->argh->input_sock, + ); } +sub dns_result { + my ($self, $result, $query) = @_; + + if ($result =~ /^[A-Z]+$/) { + # probably an error + $self->log(LOGDEBUG, "DNS error: $result looking up $query"); + return; + } + + $self->log(LOGDEBUG, "DNS lookup $query returned: $result"); + $self->transaction->notes('resolvable', 1); +} + +sub rcpt_handler { + my ($self, $transaction) = @_; + + if (!$transaction->notes('resolvable')) { + my $sender = $transaction->sender; + return (DENYSOFT, + ($sender->host + ? "Could not resolve ". $sender->host + : "FQDN required in the envelope sender")); + } + + return DECLINED; +} diff --git a/plugins/rhsbl b/plugins/rhsbl index ee45e6c..a5c7f59 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -1,38 +1,39 @@ +#!/usr/bin/perl + +use Danga::DNS; + sub register { - my ($self, $qp) = @_; + my ($self) = @_; $self->register_hook('mail', 'mail_handler'); $self->register_hook('rcpt', 'rcpt_handler'); - $self->register_hook('disconnect', 'disconnect_handler'); } sub mail_handler { my ($self, $transaction, $sender) = @_; - my $res = new Net::DNS::Resolver; - my $sel = IO::Select->new(); my %rhsbl_zones_map = (); # Perform any RHS lookups in the background. We just send the query packets here # and pick up any results in the RCPT handler. # MTAs gets confused when you reject mail during MAIL FROM: - my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones'); + my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->config('rhsbl_zones'); if ($sender->format ne '<>' and %rhsbl_zones) { - my $helo = $self->qp->connection->hello_host; + my $helo = $self->connection->hello_host; push(my @hosts, $sender->host); push(@hosts, $helo) if $helo && $helo ne $sender->host; for my $host (@hosts) { - for my $rhsbl (keys %rhsbl_zones) { + for my $rhsbl (keys %rhsbl_zones) { $self->log(LOGDEBUG, "Checking $host.$rhsbl for A record in the background"); - $sel->add($res->bgsend("$host.$rhsbl")); - $rhsbl_zones_map{"$host.$rhsbl"} = $rhsbl_zones{$rhsbl}; + Danga::DNS->new( + callback => sub { $self->process_result($host, $rhsbl_zones{$rhsbl}, @_) }, + host => "$host.$rhsbl", + client => $self->argh->input_sock, + ); + } } - } - - %{$self->{_rhsbl_zones_map}} = %rhsbl_zones_map; - $transaction->notes('rhsbl_sockets', $sel); } else { $self->log(LOGDEBUG, 'no RHS checks necessary'); } @@ -40,80 +41,28 @@ sub mail_handler { return DECLINED; } +sub process_result { + my ($self, $host, $template, $result, $query) = @_; + + if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { + # NXDOMAIN or error + return; + } + + my $tran = $self->transaction; + return if $tran->notes('rhsbl'); + if ($host eq $tran->sender->host) { + $tran->notes('rhsbl', "Mail from $host rejected because it $template"); + } + else { + $tran->notes('rhsbl', "Mail from HELO $host rejected because it $template"); + } +} + sub rcpt_handler { my ($self, $transaction, $rcpt) = @_; - my $host = $transaction->sender->host; - my $hello = $self->qp->connection->hello_host; - my $result = $self->process_sockets; - if ($result && defined($self->{_rhsbl_zones_map}{$result})) { - if ($result =~ /^$host\./ ) { - return (DENY, "Mail from $host rejected because it " . $self->{_rhsbl_zones_map}{$result}); - } else { - return (DENY, "Mail from HELO $hello rejected because it " . $self->{_rhsbl_zones_map}{$result}); - } - } + my $result = $transaction->notes('rhsbl'); return (DENY, $result) if $result; return DECLINED; } - -sub process_sockets { - my ($self) = @_; - my $trans = $self->transaction; - my $result = ''; - - return $trans->notes('rhsbl') if $trans->notes('rhsbl'); - - my $res = new Net::DNS::Resolver; - my $sel = $trans->notes('rhsbl_sockets') or return ''; - - $self->log(LOGDEBUG, 'waiting for rhsbl dns'); - - # don't wait more than 8 seconds here - my @ready = $sel->can_read(8); - - $self->log(LOGDEBUG, 'DONE waiting for rhsbl dns, got ' , scalar @ready, ' answers ...') ; - return '' unless @ready; - - for my $socket (@ready) { - my $query = $res->bgread($socket); - $sel->remove($socket); - undef $socket; - - if ($query) { - foreach my $rr ($query->answer) { - $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name); - if ($rr->type eq 'A') { - $result = $rr->name; - $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address); - last; - } - } - } else { - $self->log(LOGCRIT, "query failed: ", $res->errorstring) unless $res->errorstring eq 'NXDOMAIN'; - } - - if ($result) { - #kill any other pending I/O - $trans->notes('rhsbl_sockets', undef); - return $trans->notes('rhsbl', $result); - } - } - - if ($sel->count) { - # loop around if we have dns results left - return $self->process_sockets(); - } - - # if there was more to read; then forget it - $trans->notes('rhsbl_sockets', undef); - - return $trans->notes('rhsbl', $result); -} - -sub disconnect_handler { - my ($self, $transaction) = @_; - - $transaction->notes('rhsbl_sockets', undef); - return DECLINED; -} From 8588a066d2151d36d05b8c3e0336481942609026 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 8 Mar 2005 23:32:25 +0000 Subject: [PATCH 005/106] Fix strictness git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@390 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/PollServer.pm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 73429a2..36f3415 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -28,6 +28,7 @@ use Danga::DNS; use Mail::Header; use POSIX qw(strftime); use Socket qw(inet_aton AF_INET CRLF); +use strict; sub input_sock { my $self = shift; @@ -292,16 +293,21 @@ sub end_of_data { #$self->log(LOGDEBUG, "size is at $size\n") unless ($i % 300); - $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $size"); + $self->log(LOGDEBUG, "max_size: $self->{max_size} / size: $self->{data_size}"); my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + my $header = $self->transaction->header; + if (!$header) { + $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $self->transaction->header($header); + } # only true if client authenticated if ( defined $self->{_auth} and $self->{_auth} == OK ) { $header->add("X-Qpsmtpd-Auth","True"); } - $self->transaction->header->add("Received", "from ".$self->connection->remote_info + $header->add("Received", "from ".$self->connection->remote_info ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip . ")\n by ".$self->config('me')." (qpsmtpd/".$self->version .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), @@ -309,7 +315,7 @@ sub end_of_data { return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size}; - ($rc, $msg) = $self->run_hooks("data_post"); + my ($rc, $msg) = $self->run_hooks("data_post"); if ($rc == DONE) { return; } From 93e0025aae01e6bd49545fe3c5a1f36eaab50951 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 8 Mar 2005 23:34:51 +0000 Subject: [PATCH 006/106] Remove remnants of older name of this project :-) git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@391 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 2 +- plugins/dnsbl | 4 ++-- plugins/require_resolvable_fromhost | 4 ++-- plugins/rhsbl | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index f8cd5a1..3d43302 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -71,7 +71,7 @@ sub register { sub connect_handler { my ($self, $transaction) = @_; - if ($self->argh->can_read($self->{_args}->{'wait'})) { + if ($self->qp->can_read($self->{_args}->{'wait'})) { $self->log(LOGNOTICE, 'remote host started talking before we said hello'); if ($self->{_args}->{'defer-reject'}) { $self->connection->notes('earlytalker', 1); diff --git a/plugins/dnsbl b/plugins/dnsbl index a89beee..0a708ea 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -42,7 +42,7 @@ sub connect_handler { callback => sub { $self->process_a_result($dnsbl_zones{$dnsbl}, @_) }, host => "$reversed_ip.$dnsbl", type => 'A', - client => $self->argh->input_sock, + client => $self->qp->input_sock, ); } else { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background"); @@ -50,7 +50,7 @@ sub connect_handler { callback => sub { $self->process_txt_result(@_) }, host => "$reversed_ip.$dnsbl", type => 'TXT', - client => $self->argh->input_sock, + client => $self->qp->input_sock, ); } } diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index 48b7a95..007e8bf 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -30,12 +30,12 @@ sub check_dns { callback => sub { $self->dns_result(@_) }, host => $host, type => "MX", - client => $self->argh->input_sock, + client => $self->qp->input_sock, ); Danga::DNS->new( callback => sub { $self->dns_result(@_) }, host => $host, - client => $self->argh->input_sock, + client => $self->qp->input_sock, ); } diff --git a/plugins/rhsbl b/plugins/rhsbl index a5c7f59..96e1dec 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -30,7 +30,7 @@ sub mail_handler { Danga::DNS->new( callback => sub { $self->process_result($host, $rhsbl_zones{$rhsbl}, @_) }, host => "$host.$rhsbl", - client => $self->argh->input_sock, + client => $self->qp->input_sock, ); } } From df1efdce73aad1da61c1e9252d3b3cc4f3741483 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Wed, 9 Mar 2005 00:20:32 +0000 Subject: [PATCH 007/106] use $self->can_read rather than $self->qp->can_read with high perf patch git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@392 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 3d43302..950df60 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -70,8 +70,8 @@ sub register { sub connect_handler { my ($self, $transaction) = @_; - - if ($self->qp->can_read($self->{_args}->{'wait'})) { + + if ($self->can_read($self->{_args}->{'wait'})) { $self->log(LOGNOTICE, 'remote host started talking before we said hello'); if ($self->{_args}->{'defer-reject'}) { $self->connection->notes('earlytalker', 1); From 58f03e5787a03d663a8eeecd1f52e1d42ae29a26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Wed, 9 Mar 2005 00:28:49 +0000 Subject: [PATCH 008/106] tweaks to make it work with tcpserver the check_earlytalker fix was entirely wrong git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@393 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS.pm | 4 ++-- plugins/check_earlytalker | 2 +- qpsmtpd | 5 +++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm index e57a3a4..a3ba213 100644 --- a/lib/Danga/DNS.pm +++ b/lib/Danga/DNS.pm @@ -15,7 +15,7 @@ my $resolver; sub trace { my $level = shift; - print ("[$$] dns lookup: @_") if $::DEBUG >= $level; + print STDERR ("[$$] dns lookup: @_") if $::DEBUG >= $level; } sub new { @@ -93,7 +93,7 @@ sub DESTROY { my $now = time; foreach my $host (@{$self->{hosts}}) { if (!$self->{results}{$host}) { - print "DNS timeout (presumably) looking for $host after " . ($now - $self->{start}) . " secs\n"; + print STDERR "DNS timeout (presumably) looking for $host after " . ($now - $self->{start}) . " secs\n"; $self->{callback}->("NXDOMAIN", $host); } } diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 950df60..29d79e9 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -71,7 +71,7 @@ sub register { sub connect_handler { my ($self, $transaction) = @_; - if ($self->can_read($self->{_args}->{'wait'})) { + if ($self->qp->can_read($self->{_args}->{'wait'})) { $self->log(LOGNOTICE, 'remote host started talking before we said hello'); if ($self->{_args}->{'defer-reject'}) { $self->connection->notes('earlytalker', 1); diff --git a/qpsmtpd b/qpsmtpd index 5296717..673eb46 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -9,7 +9,8 @@ BEGIN { use strict; use vars qw($DEBUG); -use FindBin; +use FindBin qw(); +# TODO: need to make this taint friendly use lib "$FindBin::Bin/lib"; use Danga::Socket; use Danga::Client; @@ -94,7 +95,7 @@ my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : my $server; # Code for inetd/tcpserver mode -if ($ENV{REMOTE_HOST}) { +if ($ENV{REMOTE_HOST} or $ENV{TCPREMOTEHOST}) { run_as_inetd(); exit(0); } From 41e13e7454cb96a57a3efa880d6c6a94773372c2 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 10 Mar 2005 18:19:27 +0000 Subject: [PATCH 009/106] body_write patches from Brian Grossman git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@395 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/PollServer.pm | 1 + lib/Qpsmtpd/SMTP.pm | 2 +- lib/Qpsmtpd/Transaction.pm | 2 ++ 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 36f3415..c205275 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -302,6 +302,7 @@ sub end_of_data { $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); $self->transaction->header($header); } + # only true if client authenticated if ( defined $self->{_auth} and $self->{_auth} == OK ) { $header->add("X-Qpsmtpd-Auth","True"); diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 791ed99..bb463e5 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -454,7 +454,7 @@ sub data { # save us buffering the mail content. # Save the start of just the body itself - $self->transaction->body_start($size); + $self->transaction->set_body_start(); } diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 9455cea..6fe8596 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -107,10 +107,12 @@ sub body_write { while ($$ref =~ m/\G(.*?\n)/gc) { push @{ $self->{_body_array} }, $1; $self->{_body_size} += length($1); + ++$self->{_body_current_pos}; } if ($$ref =~ m/\G(.+)\z/gc) { push @{ $self->{_body_array} }, $1; $self->{_body_size} += length($1); + ++$self->{_body_current_pos}; } if ($self->{_body_size} >= $self->{_size_threshold}) { #warn("spooling to disk\n"); From ed4e06bcd29b289de49a523a1b8cb9abd1a776e8 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 11 Mar 2005 20:09:30 +0000 Subject: [PATCH 010/106] Fix timeout code kicking in when PTR result is blank domain git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@396 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm index a3ba213..f05f7de 100644 --- a/lib/Danga/DNS.pm +++ b/lib/Danga/DNS.pm @@ -92,7 +92,7 @@ sub DESTROY { my Danga::DNS $self = shift; my $now = time; foreach my $host (@{$self->{hosts}}) { - if (!$self->{results}{$host}) { + if (!exists($self->{results}{$host})) { print STDERR "DNS timeout (presumably) looking for $host after " . ($now - $self->{start}) . " secs\n"; $self->{callback}->("NXDOMAIN", $host); } From 536e1723c12ba2533f9040a636486adebb204dff Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 26 Apr 2005 02:46:45 +0000 Subject: [PATCH 011/106] Added rudimentary configuration server when running in non-forking poll mode git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@407 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS/Resolver.pm | 6 ++ lib/Qpsmtpd/ConfigServer.pm | 138 ++++++++++++++++++++++++++++++++++++ qpsmtpd | 44 +++++++++++- 3 files changed, 185 insertions(+), 3 deletions(-) create mode 100644 lib/Qpsmtpd/ConfigServer.pm diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index ded6e37..9d7a9f5 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -50,6 +50,12 @@ sub new { return $self; } +sub pending { + my Danga::DNS::Resolver $self = shift; + + return keys(%{$self->{id_to_asker}}); +} + sub _query { my Danga::DNS::Resolver $self = shift; my ($asker, $host, $type, $now) = @_; diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm new file mode 100644 index 0000000..edee148 --- /dev/null +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -0,0 +1,138 @@ +# $Id$ + +package Qpsmtpd::ConfigServer; + +use base ('Danga::Client'); + +use fields qw( + commands + _auth + _commands + _config_cache + _connection + _transaction + _test_mode + _extras +); + +sub new { + my Qpsmtpd::ConfigServer $self = shift; + + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + $self->{commands} = { help => 1, status => 1, }; + $self->write("Enter command:\n"); + return $self; +} + +sub process_line { + my $self = shift; + my $line = shift || return; + if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } + local $SIG{ALRM} = sub { + my ($pkg, $file, $line) = caller(); + die "ALARM: $pkg, $file, $line"; + }; + my $prev = alarm(2); # must process a command in < 2 seconds + my $resp = eval { $self->_process_line($line) }; + alarm($prev); + if ($@) { + print STDERR "Error: $@\n"; + } + return $resp || ''; +} + +sub respond { + my $self = shift; + my (@messages) = @_; + while (my $msg = shift @messages) { + $self->write("$msg\r\n"); + } + return; +} + +sub fault { + my $self = shift; + my ($msg) = shift || "program fault - command not performed"; + print STDERR "$0 [$$]: $msg ($!)\n"; + return $self->respond("Error - " . $msg, "Enter command:"); +} + +sub _process_line { + my $self = shift; + my $line = shift; + + $line =~ s/\r?\n//; + my ($cmd, @params) = split(/ +/, $line); + my $meth = lc($cmd); + if (my $lookup = $self->{commands}->{$meth} && $self->can($meth)) { + my $resp = eval { + $lookup->($self, @params); + }; + if ($@) { + my $error = $@; + chomp($error); + $self->log(LOGERROR, "Command Error: $error"); + return $self->fault("command '$cmd' failed unexpectedly"); + } + return $resp . "\nEnter command:\n"; + } + else { + # No such method - i.e. unrecognized command + return $self->fault("command '$cmd' unrecognised"); + } +} + +my %helptext = ( + all => "Available Commands:\n\nSTATUS\nHELP [CMD]", + status => "STATUS - Returns status information about current connections", + ); + +sub help { + my $self = shift; + my ($subcmd) = @_; + + $subcmd ||= 'all'; + $subcmd = lc($subcmd); + + my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help all'"; + warn "help returning: $txt\n"; + return $txt . "\n"; +} + +sub status { + my $self = shift; + + my $descriptors = Danga::Socket->DescriptorMap; + + my $current_connections = 0; + my $current_dns = 0; + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + $current_connections++; + } + elsif ($pob->isa("Danga::DNS::Resolver")) { + $current_dns = $pob->pending; + } + } + + return +" Current Connections: $current_connections + Current DNS Queries: $current_dns"; +} + +1; +__END__ + +=head1 NAME + +Qpsmtpd::ConfigServer - a configuration server for qpsmtpd + +=head1 DESCRIPTION + +When qpsmtpd runs in multiplex mode it also provides a config server that you +can connect to. This allows you to view current connection statistics and other +gumph that you probably don't care about. + +=cut \ No newline at end of file diff --git a/qpsmtpd b/qpsmtpd index 673eb46..6f1df6d 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -15,6 +15,7 @@ use lib "$FindBin::Bin/lib"; use Danga::Socket; use Danga::Client; use Qpsmtpd::PollServer; +use Qpsmtpd::ConfigServer; use Qpsmtpd::Constants; use IO::Socket; use Carp; @@ -31,6 +32,10 @@ use Socket qw(IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); $SIG{'PIPE'} = "IGNORE"; # handled manually $DEBUG = 0; + +my $CONFIG_PORT = 20025; +my $CONFIG_LOCALADDR = '127.0.0.1'; + my $PORT = 2525; my $LOCALADDR = '0.0.0.0'; my $LineMode = 0; @@ -93,6 +98,7 @@ my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()"); my $server; +my $config_server; # Code for inetd/tcpserver mode if ($ENV{REMOTE_HOST} or $ENV{TCPREMOTEHOST}) { @@ -200,10 +206,22 @@ sub run_as_server { Blocking => 0, Reuse => 1, Listen => 10 ) - or die "Error creating server $LOCALADDR:$PORT : $@\n"; + or die "Error creating server $LOCALADDR:$PORT : $@\n"; IO::Handle::blocking($server, 0); binmode($server, ':raw'); + + $config_server = IO::Socket::INET->new(LocalPort => $CONFIG_PORT, + LocalAddr => $CONFIG_LOCALADDR, + Type => SOCK_STREAM, + Proto => IPPROTO_TCP, + Blocking => 0, + Reuse => 1, + Listen => 1 ) + or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n"; + + IO::Handle::blocking($config_server, 0); + binmode($config_server, ':raw'); # Drop priviledges my (undef, undef, $quid, $qgid) = getpwnam $USER or @@ -240,7 +258,9 @@ sub run_as_server { } ::log(LOGDEBUG, "Listening on $PORT with single process $POLL" . ($LineMode ? " (forking server)" : "")); - Qpsmtpd::PollServer->OtherFds(fileno($server) => \&accept_handler); + Qpsmtpd::PollServer->OtherFds(fileno($server) => \&accept_handler, + fileno($config_server) => \&config_handler, + ); while (1) { Qpsmtpd::PollServer->EventLoop(); } @@ -249,6 +269,24 @@ sub run_as_server { } +sub config_handler { + my $csock = $config_server->accept(); + if (!$csock) { + warn("accept failed on config server: $!"); + return; + } + binmode($csock, ':raw'); + + printf("Config server connection\n") if $DEBUG; + + IO::Handle::blocking($csock, 0); + setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; + + my $client = Qpsmtpd::ConfigServer->new($csock); + $client->watch_read(1); + return; +} + # Accept a new connection sub accept_handler { my $running = scalar keys %childstatus; @@ -260,8 +298,8 @@ sub accept_handler { my $csock = $server->accept(); if (!$csock) { # warn("accept() failed: $!"); + return; } - return unless $csock; binmode($csock, ':raw'); printf("Listen child making a Qpsmtpd::PollServer for %d.\n", fileno($csock)) From cefae5739457cdfb114ca108ed990f8efa4a46a0 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 28 Apr 2005 21:37:01 +0000 Subject: [PATCH 012/106] Call PostEventLoop at end of Epoll event loop (same as poll() and kqueue) git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@408 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index dfaf785..1f9a0fa 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -282,6 +282,8 @@ sub EpollEventLoop { $sock->ticker; } } + + return unless PostEventLoop(); print STDERR "Event loop ending; restarting.\n"; } From a75f4a53e092b3a13595b7ddc794cb2761d2e515 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 28 Apr 2005 21:38:02 +0000 Subject: [PATCH 013/106] Fixes for early_talker under high_perf code git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@409 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 29d79e9..27f5d9c 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -44,7 +44,7 @@ and terminating the SMTP connection. =cut -use IO::Select; +use Time::HiRes (); use warnings; use strict; @@ -70,8 +70,16 @@ sub register { sub connect_handler { my ($self, $transaction) = @_; + my $qp = $self->qp; + my $end = Time::HiRes::time + $self->{_args}->{'wait'} ; + my $time; + for( $time = Time::HiRes::time; $time < $end && !length($qp->{line}) ; $time = Time::HiRes::time ) { + $qp->can_read($end-$time); + } + my $earlytalker = 0; + $earlytalker = 1 if $time < $end ; - if ($self->qp->can_read($self->{_args}->{'wait'})) { + if ($earlytalker) { $self->log(LOGNOTICE, 'remote host started talking before we said hello'); if ($self->{_args}->{'defer-reject'}) { $self->connection->notes('earlytalker', 1); From 46cda051122415f4be75068493ea18807a1672e7 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 28 Apr 2005 21:38:43 +0000 Subject: [PATCH 014/106] Much improved config server, especially the stats git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@410 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/ConfigServer.pm | 182 ++++++++++++++++++++++++++++++++---- lib/Qpsmtpd/PollServer.pm | 9 ++ lib/Qpsmtpd/Stats.pm | 35 +++++++ plugins/stats | 31 ++++++ qpsmtpd | 39 +++++--- 5 files changed, 264 insertions(+), 32 deletions(-) create mode 100644 lib/Qpsmtpd/Stats.pm create mode 100644 plugins/stats diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm index edee148..ff5e2b8 100644 --- a/lib/Qpsmtpd/ConfigServer.pm +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -3,9 +3,11 @@ package Qpsmtpd::ConfigServer; use base ('Danga::Client'); +use Qpsmtpd::Constants; + +use strict; use fields qw( - commands _auth _commands _config_cache @@ -15,16 +17,19 @@ use fields qw( _extras ); +my $PROMPT = "Enter command: "; + sub new { my Qpsmtpd::ConfigServer $self = shift; $self = fields::new($self) unless ref $self; $self->SUPER::new( @_ ); - $self->{commands} = { help => 1, status => 1, }; - $self->write("Enter command:\n"); + $self->write($PROMPT); return $self; } +sub max_idle_time { 3600 } # one hour + sub process_line { my $self = shift; my $line = shift || return; @@ -55,7 +60,8 @@ sub fault { my $self = shift; my ($msg) = shift || "program fault - command not performed"; print STDERR "$0 [$$]: $msg ($!)\n"; - return $self->respond("Error - " . $msg, "Enter command:"); + $self->respond("Error - " . $msg); + return $PROMPT; } sub _process_line { @@ -64,18 +70,18 @@ sub _process_line { $line =~ s/\r?\n//; my ($cmd, @params) = split(/ +/, $line); - my $meth = lc($cmd); - if (my $lookup = $self->{commands}->{$meth} && $self->can($meth)) { + my $meth = "cmd_" . lc($cmd); + if (my $lookup = $self->can($meth)) { my $resp = eval { $lookup->($self, @params); }; if ($@) { my $error = $@; chomp($error); - $self->log(LOGERROR, "Command Error: $error"); + Qpsmtpd->log(LOGERROR, "Command Error: $error"); return $self->fault("command '$cmd' failed unexpectedly"); } - return $resp . "\nEnter command:\n"; + return "$resp\n$PROMPT"; } else { # No such method - i.e. unrecognized command @@ -84,24 +90,74 @@ sub _process_line { } my %helptext = ( - all => "Available Commands:\n\nSTATUS\nHELP [CMD]", + help => "HELP [CMD] - Get help on all commands or a specific command", status => "STATUS - Returns status information about current connections", + list => "LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list", + kill => "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF", + pause => "PAUSE - Stop accepting new connections", + continue => "CONTINUE - Resume accepting connections", + reload => "RELOAD - Reload all plugins and config", + quit => "QUIT - Exit the config server", ); -sub help { +sub cmd_help { my $self = shift; my ($subcmd) = @_; - $subcmd ||= 'all'; + $subcmd ||= 'help'; $subcmd = lc($subcmd); - my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help all'"; - warn "help returning: $txt\n"; - return $txt . "\n"; + if ($subcmd eq 'help') { + my $txt = join("\n", map { substr($_, 0, index($_, "-")) } sort values(%helptext)); + return "Available Commands:\n\n$txt\n"; + } + my $txt = $helptext{$subcmd} || "Unrecognised help option. Try 'help' for a full list."; + return "$txt\n"; } -sub status { +sub cmd_quit { my $self = shift; + $self->close; +} + +sub cmd_pause { + my $self = shift; + + my $other_fds = $self->OtherFds; + + $self->{other_fds} = { %$other_fds }; + %$other_fds = (); + return "PAUSED"; +} + +sub cmd_status { + my $self = shift; + +# Status should show: +# - Total time running +# - Total number of mails received +# - Total number of mails rejected (5xx) +# - Total number of mails tempfailed (5xx) +# - Avg number of mails/minute +# - Number of current connections +# - Number of outstanding DNS queries + + my $output = "Current Status as of " . gmtime() . " GMT\n\n"; + + if ($INC{'Qpsmtpd/Stats.pm'}) { + # Stats plugin is loaded + my $uptime = Qpsmtpd::Stats->uptime; + my $recvd = Qpsmtpd::Stats->mails_received; + my $reject = Qpsmtpd::Stats->mails_rejected; + my $soft = Qpsmtpd::Stats->mails_tempfailed; + my $rate = Qpsmtpd::Stats->mails_per_sec; + $output .= sprintf(" Uptime: %0.2f sec\n". + " Mails Received: % 10d\n". + " 5xx: % 10d\n". + " 4xx: % 10d\n". + "Mails per second: %0.2f\n", + $uptime, $recvd, $reject, $soft, $rate); + } my $descriptors = Danga::Socket->DescriptorMap; @@ -117,9 +173,99 @@ sub status { } } - return -" Current Connections: $current_connections - Current DNS Queries: $current_dns"; + $output .= "Curr Connections: $current_connections\n". + "Curr DNS Queries: $current_dns"; + + return $output; +} + +sub cmd_list { + my $self = shift; + my ($count) = @_; + + my $descriptors = Danga::Socket->DescriptorMap; + + my $list = "Current" . ($count ? (($count > 0) ? " Oldest $count" : " Newest ".-$count) : "") . " Connections: \n\n"; + my @all; + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + next unless $pob->connection->remote_ip; # haven't even started yet + push @all, [$pob+0, $pob->connection->remote_ip, + $pob->connection->remote_host, $pob->uptime]; + } + } + + @all = sort { $a->[3] <=> $b->[3] } @all; + if ($count) { + if ($count > 0) { + @all = @all[$#all-($count-1) .. $#all]; + } + else { + @all = @all[0..(abs($count) - 1)]; + } + } + foreach my $item (@all) { + $list .= sprintf("%x : %s [%s] Connected %0.2fs\n", @$item); + } + + return $list; +} + +sub cmd_kill { + my $self = shift; + my ($match) = @_; + + return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match; + + my $descriptors = Danga::Socket->DescriptorMap; + + my $killed = 0; + my $is_ip = (index($match, '.') >= 0); + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + if ($is_ip) { + next unless $pob->connection->remote_ip; # haven't even started yet + if ($pob->connection->remote_ip eq $match) { + $pob->write("550 Your connection has been killed by an administrator\r\n"); + $pob->disconnect; + $killed++; + } + } + else { + # match by ID + if ($pob+0 == hex($match)) { + $pob->write("550 Your connection has been killed by an administrator\r\n"); + $pob->disconnect; + $killed++; + } + } + } + } + + return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n"; +} + +sub cmd_dump { + my $self = shift; + my ($ref) = @_; + + return "SYNTAX: DUMP \$REF\n" unless $ref; + require Data::Dumper; + $Data::Dumper::Indent=1; + + my $descriptors = Danga::Socket->DescriptorMap; + foreach my $fd (keys %$descriptors) { + my $pob = $descriptors->{$fd}; + if ($pob->isa("Qpsmtpd::PollServer")) { + if ($pob+0 == hex($ref)) { + return Data::Dumper::Dumper($pob); + } + } + } + + return "Unable to find the connection: $ref. Try the LIST command\n"; } 1; diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index c205275..991d5f0 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -13,6 +13,7 @@ use fields qw( data_size max_size hooks + start_time _auth _commands _config_cache @@ -28,6 +29,7 @@ use Danga::DNS; use Mail::Header; use POSIX qw(strftime); use Socket qw(inet_aton AF_INET CRLF); +use Time::HiRes qw(time); use strict; sub input_sock { @@ -41,10 +43,17 @@ sub new { $self = fields::new($self) unless ref $self; $self->SUPER::new( @_ ); + $self->{start_time} = time; $self->load_plugins; return $self; } +sub uptime { + my Qpsmtpd::PollServer $self = shift; + + return (time() - $self->{start_time}); +} + sub reset_for_next_message { my $self = shift; $self->SUPER::reset_for_next_message(@_); diff --git a/lib/Qpsmtpd/Stats.pm b/lib/Qpsmtpd/Stats.pm new file mode 100644 index 0000000..a858b9f --- /dev/null +++ b/lib/Qpsmtpd/Stats.pm @@ -0,0 +1,35 @@ +# $Id$ + +package Qpsmtpd::Stats; + +use strict; +use Qpsmtpd; +use Qpsmtpd::Constants; +use Time::HiRes qw(time); + +my $START_TIME = time; +our $MAILS_RECEIVED = 0; +our $MAILS_REJECTED = 0; +our $MAILS_TEMPFAIL = 0; + +sub uptime { + return (time() - $START_TIME); +} + +sub mails_received { + return $MAILS_RECEIVED; +} + +sub mails_rejected { + return $MAILS_REJECTED; +} + +sub mails_tempfailed { + return $MAILS_TEMPFAIL; +} + +sub mails_per_sec { + return ($MAILS_RECEIVED / uptime()); +} + +1; \ No newline at end of file diff --git a/plugins/stats b/plugins/stats new file mode 100644 index 0000000..d7aa604 --- /dev/null +++ b/plugins/stats @@ -0,0 +1,31 @@ +#!/usr/bin/perl -w + +use Qpsmtpd::Stats; + +sub register { + my ($self) = @_; + + $self->register_hook('deny', 'increment_deny'); + $self->register_hook('queue', 'increment_mails'); +} + +sub increment_deny { + my ($self, $level) = @_; + + if ($level == DENY or $level == DENY_DISCONNECT) { + $Qpsmtpd::Stats::MAILS_REJECTED++; + } + elsif ($level == DENYSOFT or $level == DENYSOFT_DISCONNECT) { + $Qpsmtpd::Stats::MAILS_TEMPFAIL++; + } + + return DECLINED; +} + +sub increment_mails { + my $self = shift; + + $Qpsmtpd::Stats::MAILS_RECEIVED++; + + return DECLINED; +} \ No newline at end of file diff --git a/qpsmtpd b/qpsmtpd index 6f1df6d..928948e 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -43,6 +43,7 @@ my $PROCS = 1; my $MAXCONN = 15; # max simultaneous connections my $USER = 'smtpd'; # user to suid to my $MAXCONNIP = 5; # max simultaneous connections from one IP +my $PAUSED = 0; sub help { print <OtherFds(fileno($server) => \&accept_handler); + Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler); Qpsmtpd::PollServer->EventLoop(); exit; } @@ -199,7 +200,7 @@ sub run_as_inetd { sub run_as_server { # establish SERVER socket, bind and listen. - $server = IO::Socket::INET->new(LocalPort => $PORT, + $SERVER = IO::Socket::INET->new(LocalPort => $PORT, LocalAddr => $LOCALADDR, Type => SOCK_STREAM, Proto => IPPROTO_TCP, @@ -208,10 +209,10 @@ sub run_as_server { Listen => 10 ) or die "Error creating server $LOCALADDR:$PORT : $@\n"; - IO::Handle::blocking($server, 0); - binmode($server, ':raw'); + IO::Handle::blocking($SERVER, 0); + binmode($SERVER, ':raw'); - $config_server = IO::Socket::INET->new(LocalPort => $CONFIG_PORT, + $CONFIG_SERVER = IO::Socket::INET->new(LocalPort => $CONFIG_PORT, LocalAddr => $CONFIG_LOCALADDR, Type => SOCK_STREAM, Proto => IPPROTO_TCP, @@ -220,8 +221,8 @@ sub run_as_server { Listen => 1 ) or die "Error creating server $CONFIG_LOCALADDR:$CONFIG_PORT : $@\n"; - IO::Handle::blocking($config_server, 0); - binmode($config_server, ':raw'); + IO::Handle::blocking($CONFIG_SERVER, 0); + binmode($CONFIG_SERVER, ':raw'); # Drop priviledges my (undef, undef, $quid, $qgid) = getpwnam $USER or @@ -258,8 +259,8 @@ sub run_as_server { } ::log(LOGDEBUG, "Listening on $PORT with single process $POLL" . ($LineMode ? " (forking server)" : "")); - Qpsmtpd::PollServer->OtherFds(fileno($server) => \&accept_handler, - fileno($config_server) => \&config_handler, + Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler, + fileno($CONFIG_SERVER) => \&config_handler, ); while (1) { Qpsmtpd::PollServer->EventLoop(); @@ -270,7 +271,7 @@ sub run_as_server { } sub config_handler { - my $csock = $config_server->accept(); + my $csock = $CONFIG_SERVER->accept(); if (!$csock) { warn("accept failed on config server: $!"); return; @@ -295,7 +296,7 @@ sub accept_handler { return; } - my $csock = $server->accept(); + my $csock = $SERVER->accept(); if (!$csock) { # warn("accept() failed: $!"); return; @@ -313,6 +314,12 @@ sub accept_handler { my $client = Qpsmtpd::PollServer->new($csock); my $rem_ip = $client->peer_ip_string; + if ($PAUSED) { + $client->write("451 Sorry, this server is currently paused\r\n"); + $client->close; + return; + } + if ($MAXCONNIP) { my $num_conn = 1; # seed with current value @@ -370,7 +377,7 @@ sub accept_handler { return $csock->close(); } - $server->close(); # make sure the child doesn't accept() new connections + $SERVER->close(); # make sure the child doesn't accept() new connections $SIG{$_} = 'DEFAULT' for keys %SIG; @@ -406,3 +413,7 @@ sub log { warn("$$ $message\n"); } +sub pause { + my ($pause) = @_; + $PAUSED = $pause; +} From 12d9fa8311649149a14c6641c3a72018954ab3a8 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 9 May 2005 13:41:10 +0000 Subject: [PATCH 015/106] Fix deny incrementing to use proper variables git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@412 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/stats | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/stats b/plugins/stats index d7aa604..200cac9 100644 --- a/plugins/stats +++ b/plugins/stats @@ -10,7 +10,7 @@ sub register { } sub increment_deny { - my ($self, $level) = @_; + my ($self, $tran, $plugin, $level) = @_; if ($level == DENY or $level == DENY_DISCONNECT) { $Qpsmtpd::Stats::MAILS_REJECTED++; @@ -28,4 +28,4 @@ sub increment_mails { $Qpsmtpd::Stats::MAILS_RECEIVED++; return DECLINED; -} \ No newline at end of file +} From 8dad7435e57b3d05d7a9b86040d39b925768fdcb Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 9 May 2005 13:43:40 +0000 Subject: [PATCH 016/106] Large number of patches from Brian Grossman to fix a number of bugs Implement connection timeout git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@413 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 7 ++++--- lib/Danga/DNS/Resolver.pm | 3 +++ lib/Danga/Socket.pm | 34 +++++++++++++++++++++++++++++----- lib/Danga/TimeoutSocket.pm | 32 ++++++++++++++++++++++++++++---- lib/Qpsmtpd/ConfigServer.pm | 15 +++++++++++++-- lib/Qpsmtpd/Plugin.pm | 2 +- lib/Qpsmtpd/PollServer.pm | 6 +++++- plugins/check_earlytalker | 22 +++++++--------------- qpsmtpd | 12 +++++++++++- 9 files changed, 101 insertions(+), 32 deletions(-) diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index 7b13477..5fb002a 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -6,7 +6,8 @@ use fields qw(line closing disable_read can_read_mode); use Time::HiRes (); # 30 seconds max timeout! -sub max_idle_time { 30 } +sub max_idle_time { 30 } +sub max_connect_time { 1200 } sub new { my Danga::Client $self = shift; @@ -45,7 +46,7 @@ sub can_read { my Danga::Client $self = shift; my ($timeout) = @_; my $end = Time::HiRes::time() + $timeout; - warn("Calling can-read\n"); + # warn("Calling can-read\n"); $self->{can_read_mode} = 1; if (!length($self->{line})) { my $old = $self->watch_read(); @@ -61,7 +62,7 @@ sub can_read { $self->SetPostLoopCallback(sub { $self->have_line ? 0 : 1 }); return if $self->{closing}; $self->{alive_time} = time; - warn("can_read returning for '$self->{line}'\n"); + # warn("can_read returning for '$self->{line}'\n"); return 1 if length($self->{line}); return; } diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 9d7a9f5..80dec78 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -286,6 +286,9 @@ sub event_read { #$self->{timeout}{$id} = time(); } + elsif ($err eq "NOERROR") { + $asker->run_callback($err, $query); + } elsif($err) { print("error: $err\n"); $asker->run_callback($err, $query); diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 1f9a0fa..bb4de76 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -24,7 +24,7 @@ use vars qw{$VERSION}; $VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; use fields qw(sock fd write_buf write_buf_offset write_buf_size - read_push_back + read_push_back post_loop_callback closed event_watch debug_level); use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN @@ -307,9 +307,21 @@ sub PostEventLoop { # now we can close sockets that wanted to close during our event processing. # (we didn't want to close them during the loop, as we didn't want fd numbers # being reused and confused during the event loop) - $_->close while ($_ = shift @ToClose); + while(my $j = shift @ToClose) { + $j->[1]->close(); + $j->[0]->{closing} = 0; + } - # now we're at the very end, call callback if defined + + # now we're at the very end, call per-connection callbacks if defined + for my $fd (%DescriptorMap) { + my $pob = $DescriptorMap{$fd}; + if( defined $pob->{post_loop_callback} ) { + return unless $pob->{post_loop_callback}->(\%DescriptorMap, \%OtherFds); + } + } + + # now we're at the very end, call global callback if defined if (defined $PostLoopCallback) { return $PostLoopCallback->(\%DescriptorMap, \%OtherFds); } @@ -401,6 +413,7 @@ sub new { $self->{write_buf_size} = 0; $self->{closed} = 0; $self->{read_push_back} = []; + $self->{post_loop_callback} = undef; $self->{event_watch} = POLLERR|POLLHUP|POLLNVAL; @@ -472,7 +485,7 @@ sub close { # defer closing the actual socket until the event loop is done # processing this round of events. (otherwise we might reuse fds) - push @ToClose, $sock; + push @ToClose, [$self,$sock]; return 0; } @@ -785,7 +798,18 @@ sub as_string { ### be passed two parameters: \%DescriptorMap, \%OtherFds. sub SetPostLoopCallback { my ($class, $ref) = @_; - $PostLoopCallback = (defined $ref && ref $ref eq 'CODE') ? $ref : undef; + if(ref $class) { + my Danga::Socket $self = $class; + if( defined $ref && ref $ref eq 'CODE' ) { + $self->{PostLoopCallback} = $ref; + } + else { + delete $self->{PostLoopCallback}; + } + } + else { + $PostLoopCallback = (defined $ref && ref $ref eq 'CODE') ? $ref : undef; + } } ##################################################################### diff --git a/lib/Danga/TimeoutSocket.pm b/lib/Danga/TimeoutSocket.pm index fe74cd9..c9468d2 100644 --- a/lib/Danga/TimeoutSocket.pm +++ b/lib/Danga/TimeoutSocket.pm @@ -24,22 +24,46 @@ sub new { return $self; } +sub ticker { + my Danga::TimeoutSocket $self = shift; + + my $now = time; + + if ($now - 15 > $last_cleanup) { + $last_cleanup = $now; + _do_cleanup($now); + } +} + +# overload these in a subclass +sub max_idle_time { 0 } +sub max_connect_time { 0 } + sub _do_cleanup { my $now = shift; my $sf = __PACKAGE__->get_sock_ref; my %max_age; # classname -> max age (0 means forever) + my %max_connect; # classname -> max connect time my @to_close; while (my $k = each %$sf) { my Danga::TimeoutSocket $v = $sf->{$k}; my $ref = ref $v; next unless $v->isa('Danga::TimeoutSocket'); unless (defined $max_age{$ref}) { - $max_age{$ref} = $ref->max_idle_time || 0; + $max_age{$ref} = $ref->max_idle_time || 0; + $max_connect{$ref} = $ref->max_connect_time || 0; } - next unless $max_age{$ref}; - if ($v->{alive_time} < $now - $max_age{$ref}) { - push @to_close, $v; + if (my $t = $max_connect{$ref}) { + if ($v->{create_time} < $now - $t) { + push @to_close, $v; + next; + } + } + if (my $t = $max_age{$ref}) { + if ($v->{alive_time} < $now - $t) { + push @to_close, $v; + } } } diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm index ff5e2b8..fd2c8a7 100644 --- a/lib/Qpsmtpd/ConfigServer.pm +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -15,6 +15,7 @@ use fields qw( _transaction _test_mode _extras + other_fds ); my $PROMPT = "Enter command: "; @@ -130,6 +131,16 @@ sub cmd_pause { return "PAUSED"; } +sub cmd_continue { + my $self = shift; + + my $other_fds = $self->{other_fds}; + + $self->OtherFds( %$other_fds ); + %$other_fds = (); + return "UNPAUSED"; +} + sub cmd_status { my $self = shift; @@ -173,7 +184,7 @@ sub cmd_status { } } - $output .= "Curr Connections: $current_connections\n". + $output .= "Curr Connections: $current_connections / $::MAXconn\n". "Curr DNS Queries: $current_dns"; return $output; @@ -206,7 +217,7 @@ sub cmd_list { } } foreach my $item (@all) { - $list .= sprintf("%x : %s [%s] Connected %0.2fs\n", @$item); + $list .= sprintf("%x : %s [%s] Connected %0.2fs\n", map { defined()?$_:'' } @$item); } return $list; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 25836a4..c5fefae 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -108,7 +108,7 @@ sub compile { } close F; - my $line = "\n#line 1 $file\n"; + my $line = "\n#line 0 $file\n"; if ($test_mode) { if (open(F, "t/plugin_tests/$plugin")) { diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 991d5f0..5e14362 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -32,6 +32,9 @@ use Socket qw(inet_aton AF_INET CRLF); use Time::HiRes qw(time); use strict; +sub max_idle_time { 60 } +sub max_connect_time { 1200 } + sub input_sock { my $self = shift; @_ and $self->{input_sock} = shift; @@ -91,7 +94,7 @@ sub process_line { if ($::DEBUG > 1) { print "$$:".($self+0)."C($self->{mode}): $line"; } local $SIG{ALRM} = sub { my ($pkg, $file, $line) = caller(); - die "ALARM: $pkg, $file, $line"; + die "ALARM: ($self->{mode}) $pkg, $file, $line"; }; my $prev = alarm(2); # must process a command in < 2 seconds eval { $self->_process_line($line) }; @@ -169,6 +172,7 @@ sub start_conversation { my ($ip, $port) = split(':', $self->peer_addr_string); $conn->remote_ip($ip); $conn->remote_port($port); + $conn->remote_info("[$ip]"); Danga::DNS->new( client => $self, # NB: Setting remote_info to the same as remote_host diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 27f5d9c..7256e88 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -44,8 +44,6 @@ and terminating the SMTP connection. =cut -use Time::HiRes (); - use warnings; use strict; @@ -70,25 +68,19 @@ sub register { sub connect_handler { my ($self, $transaction) = @_; - my $qp = $self->qp; - my $end = Time::HiRes::time + $self->{_args}->{'wait'} ; - my $time; - for( $time = Time::HiRes::time; $time < $end && !length($qp->{line}) ; $time = Time::HiRes::time ) { - $qp->can_read($end-$time); - } - my $earlytalker = 0; - $earlytalker = 1 if $time < $end ; - - if ($earlytalker) { + + if ($self->qp->can_read($self->{_args}->{'wait'})) { $self->log(LOGNOTICE, 'remote host started talking before we said hello'); if ($self->{_args}->{'defer-reject'}) { - $self->connection->notes('earlytalker', 1); - } else { + $self->connection->notes('earlytalker', 1); + } + else { my $msg = 'Connecting host started transmitting before SMTP greeting'; return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; } - } else { + } + else { $self->log(LOGINFO, 'remote host said nothing spontaneous, proceeding'); } return DECLINED; diff --git a/qpsmtpd b/qpsmtpd index 928948e..96883ae 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -199,6 +199,7 @@ sub run_as_inetd { } sub run_as_server { + local $::MAXconn = $MAXCONN; # establish SERVER socket, bind and listen. $SERVER = IO::Socket::INET->new(LocalPort => $PORT, LocalAddr => $LOCALADDR, @@ -290,11 +291,19 @@ sub config_handler { # Accept a new connection sub accept_handler { - my $running = scalar keys %childstatus; + my $running; + if( $LineMode ) { + $running = scalar keys %childstatus; + } + else { + my $descriptors = Danga::Client->DescriptorMap; + $running = scalar keys %$descriptors; + } while ($running >= $MAXCONN) { ::log(LOGINFO,"Too many connections: $running >= $MAXCONN."); return; } + ++$running if $LineMode; # count self my $csock = $SERVER->accept(); if (!$csock) { @@ -341,6 +350,7 @@ sub accept_handler { $client->close; return; } + ::log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip"); } my $rc = $client->start_conversation; From 726128aef6c6fd4021f9e7bf1565cdb956dacbb2 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 9 May 2005 13:49:40 +0000 Subject: [PATCH 017/106] Fixed typo in post_loop_callback name git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@414 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index bb4de76..21f2d4a 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -801,10 +801,10 @@ sub SetPostLoopCallback { if(ref $class) { my Danga::Socket $self = $class; if( defined $ref && ref $ref eq 'CODE' ) { - $self->{PostLoopCallback} = $ref; + $self->{post_loop_callback} = $ref; } else { - delete $self->{PostLoopCallback}; + delete $self->{post_loop_callback}; } } else { From 7633e038c106f4eb9c004f111b61a46ded3f86e8 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 12 May 2005 12:57:05 +0000 Subject: [PATCH 018/106] Use class logging where we can so we get proper log levels Accept all new incoming connections not just one git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@415 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/qpsmtpd b/qpsmtpd index 96883ae..7b9f989 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -251,14 +251,14 @@ sub run_as_server { push @kids, spawn_child(); } $SIG{INT} = $SIG{TERM} = sub { $SIG{CHLD} = "IGNORE"; kill 2 => @kids; exit }; - ::log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL"); + $plugin_loader->log(LOGDEBUG, "Listening on $PORT with $PROCS children $POLL"); sleep while (1); } else { if ($LineMode) { $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; } - ::log(LOGDEBUG, "Listening on $PORT with single process $POLL" . + $plugin_loader->log(LOGDEBUG, "Listening on $PORT with single process $POLL" . ($LineMode ? " (forking server)" : "")); Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler, fileno($CONFIG_SERVER) => \&config_handler, @@ -274,7 +274,7 @@ sub run_as_server { sub config_handler { my $csock = $CONFIG_SERVER->accept(); if (!$csock) { - warn("accept failed on config server: $!"); + # warn("accept failed on config server: $!"); return; } binmode($csock, ':raw'); @@ -289,9 +289,15 @@ sub config_handler { return; } -# Accept a new connection +# Accept all new connections sub accept_handler { - my $running; + for (1..10000) { + last unless _accept_handler(); + } +} + +sub _accept_handler { + my $running; if( $LineMode ) { $running = scalar keys %childstatus; } @@ -299,7 +305,7 @@ sub accept_handler { my $descriptors = Danga::Client->DescriptorMap; $running = scalar keys %$descriptors; } - while ($running >= $MAXCONN) { + if ($running >= $MAXCONN) { ::log(LOGINFO,"Too many connections: $running >= $MAXCONN."); return; } @@ -326,7 +332,7 @@ sub accept_handler { if ($PAUSED) { $client->write("451 Sorry, this server is currently paused\r\n"); $client->close; - return; + return 1; } if ($MAXCONNIP) { @@ -344,22 +350,22 @@ sub accept_handler { } if ($num_conn > $MAXCONNIP) { - ::log(LOGINFO,"Too many connections from $rem_ip: " + $client->log(LOGINFO,"Too many connections from $rem_ip: " ."$num_conn > $MAXCONNIP. Denying connection."); $client->write("451 Sorry, too many connections from $rem_ip, try again later\r\n"); $client->close; - return; + return 1; } - ::log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip"); + $client->log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip"); } my $rc = $client->start_conversation; if ($rc != DONE) { $client->close; - return; + return 1; } $client->watch_read(1); - return; + return 1; } # fork-per-connection mode @@ -378,7 +384,7 @@ sub accept_handler { ."$num_conn > $MAXCONNIP. Denying connection."); print $csock "451 Sorry, too many connections from $rem_ip, try again later\r\n"; close $csock; - return; + return 1; } } @@ -408,7 +414,7 @@ sub accept_handler { $client->watch_read(1); } - ::log(LOGDEBUG, "Finished with child %d.\n", fileno($csock)) + $client->log(LOGDEBUG, "Finished with child %d.\n", fileno($csock)) if $DEBUG; $client->close(); From c0c5078f8289ee53948706543a63208bb83c57c5 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 12 May 2005 12:58:13 +0000 Subject: [PATCH 019/106] Fix warning git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@416 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Transaction.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 6fe8596..dd075de 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -160,6 +160,7 @@ sub body_getline { } else { return unless $self->{_body_array}; + $self->{_body_current_pos} ||= 0; my $line = $self->{_body_array}->[$self->{_body_current_pos}]; $self->{_body_current_pos}++; return $line; From e743c5903c1e13f1217500988862c5aadba5fbb8 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 12 May 2005 22:08:20 +0000 Subject: [PATCH 020/106] Cache the peer_ip git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@417 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 91 +++++++++++++++++++++++++-------------------- 1 file changed, 51 insertions(+), 40 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 21f2d4a..aa64b94 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -25,6 +25,7 @@ $VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $# use fields qw(sock fd write_buf write_buf_offset write_buf_size read_push_back post_loop_callback + peer_ip closed event_watch debug_level); use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN @@ -72,9 +73,11 @@ our ( %OtherFds, # A hash of "other" (non-Danga::Socket) file # descriptors for the event loop to track. $PostLoopCallback, # subref to call at the end of each loop, if defined + $LocalPostLoopCallback, # true if there is a local post loop callback in effect ); %OtherFds = (); +$LocalPostLoopCallback = 0; ##################################################################### ### C L A S S M E T H O D S @@ -290,44 +293,6 @@ sub EpollEventLoop { exit 0; } -sub PostEventLoop { - # fire read events for objects with pushed-back read data - my $loop = 1; - while ($loop) { - $loop = 0; - foreach my $fd (keys %PushBackSet) { - my Danga::Socket $pob = $PushBackSet{$fd}; - next unless (! $pob->{closed} && - $pob->{event_watch} & POLLIN); - $loop = 1; - $pob->event_read; - } - } - - # now we can close sockets that wanted to close during our event processing. - # (we didn't want to close them during the loop, as we didn't want fd numbers - # being reused and confused during the event loop) - while(my $j = shift @ToClose) { - $j->[1]->close(); - $j->[0]->{closing} = 0; - } - - - # now we're at the very end, call per-connection callbacks if defined - for my $fd (%DescriptorMap) { - my $pob = $DescriptorMap{$fd}; - if( defined $pob->{post_loop_callback} ) { - return unless $pob->{post_loop_callback}->(\%DescriptorMap, \%OtherFds); - } - } - - # now we're at the very end, call global callback if defined - if (defined $PostLoopCallback) { - return $PostLoopCallback->(\%DescriptorMap, \%OtherFds); - } - return 1; -} - ### The fallback IO::Poll-based event loop. Gets installed as EventLoop if ### IO::Epoll fails to load. sub PollEventLoop { @@ -385,6 +350,47 @@ sub PollEventLoop { exit 0; } +## PostEventLoop is called at the end of the event loop to process things +# like close() calls. +sub PostEventLoop { + # fire read events for objects with pushed-back read data + my $loop = 1; + while ($loop) { + $loop = 0; + foreach my $fd (keys %PushBackSet) { + my Danga::Socket $pob = $PushBackSet{$fd}; + next unless (! $pob->{closed} && + $pob->{event_watch} & POLLIN); + $loop = 1; + $pob->event_read; + } + } + + # now we can close sockets that wanted to close during our event processing. + # (we didn't want to close them during the loop, as we didn't want fd numbers + # being reused and confused during the event loop) + foreach my $f (@ToClose) { + close($f); + } + @ToClose = (); + + # now we're at the very end, call per-connection callbacks if defined + if ($LocalPostLoopCallback) { + for my $fd (%DescriptorMap) { + my $pob = $DescriptorMap{$fd}; + if( defined $pob->{post_loop_callback} ) { + return unless $pob->{post_loop_callback}->(\%DescriptorMap, \%OtherFds); + } + } + } + + # now we're at the very end, call global callback if defined + if (defined $PostLoopCallback) { + return $PostLoopCallback->(\%DescriptorMap, \%OtherFds); + } + return 1; +} + ### (CLASS) METHOD: DebugMsg( $format, @args ) ### Print the debugging message specified by the C-style I and @@ -485,7 +491,7 @@ sub close { # defer closing the actual socket until the event loop is done # processing this round of events. (otherwise we might reuse fds) - push @ToClose, [$self,$sock]; + push @ToClose, $sock; return 0; } @@ -764,9 +770,12 @@ sub debugmsg { ### Returns the string describing the peer's IP sub peer_ip_string { my Danga::Socket $self = shift; + return $self->{peer_ip} if defined $self->{peer_ip}; my $pn = getpeername($self->{sock}) or return undef; my ($port, $iaddr) = Socket::sockaddr_in($pn); - return Socket::inet_ntoa($iaddr); + my $r = Socket::inet_ntoa($iaddr); + $self->{peer_ip} = $r; + return $r; } ### METHOD: peer_addr_string() @@ -801,9 +810,11 @@ sub SetPostLoopCallback { if(ref $class) { my Danga::Socket $self = $class; if( defined $ref && ref $ref eq 'CODE' ) { + $LocalPostLoopCallback++; $self->{post_loop_callback} = $ref; } else { + $LocalPostLoopCallback--; delete $self->{post_loop_callback}; } } From 37c96a17734f374e156e7c9e8bd0c30c28afe1d0 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 12 May 2005 22:08:37 +0000 Subject: [PATCH 021/106] Cache the hooks git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@418 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index d8593d8..6d07d20 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -122,9 +122,15 @@ sub _config_from_file { return wantarray ? @config : $config[0]; } +our $HOOKS; + sub load_plugins { my $self = shift; - + + if ($HOOKS) { + return $self->{hooks} = $HOOKS; + } + $self->log(LOGERROR, "Plugins already loaded") if $self->{hooks}; $self->{hooks} = {}; @@ -135,6 +141,8 @@ sub load_plugins { @plugins = $self->_load_plugins($dir, @plugins); + $HOOKS = $self->{hooks}; + return @plugins; } From e3a5d6c3c699583af470954c3e90ed1c144c490e Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 12 May 2005 23:04:53 +0000 Subject: [PATCH 022/106] Make post loop callbacks a local var so we don't have to iterate through as much git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@419 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index aa64b94..95c9c2e 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -73,7 +73,7 @@ our ( %OtherFds, # A hash of "other" (non-Danga::Socket) file # descriptors for the event loop to track. $PostLoopCallback, # subref to call at the end of each loop, if defined - $LocalPostLoopCallback, # true if there is a local post loop callback in effect + %PLCMap, # fd (num) -> PostLoopCallback ); %OtherFds = (); @@ -375,13 +375,8 @@ sub PostEventLoop { @ToClose = (); # now we're at the very end, call per-connection callbacks if defined - if ($LocalPostLoopCallback) { - for my $fd (%DescriptorMap) { - my $pob = $DescriptorMap{$fd}; - if( defined $pob->{post_loop_callback} ) { - return unless $pob->{post_loop_callback}->(\%DescriptorMap, \%OtherFds); - } - } + for my $plc (values %PLCMap) { + return unless $plc->(\%DescriptorMap, \%OtherFds); } # now we're at the very end, call global callback if defined @@ -810,12 +805,10 @@ sub SetPostLoopCallback { if(ref $class) { my Danga::Socket $self = $class; if( defined $ref && ref $ref eq 'CODE' ) { - $LocalPostLoopCallback++; - $self->{post_loop_callback} = $ref; + $PLCMap{$self->{fd}} = $ref; } else { - $LocalPostLoopCallback--; - delete $self->{post_loop_callback}; + delete $PLCMap{$self->{fd}}; } } else { @@ -823,6 +816,11 @@ sub SetPostLoopCallback { } } +sub DESTROY { + my Danga::Socket $self = shift; + delete $PLCMap{$self->{fd}}; +} + ##################################################################### ### U T I L I T Y F U N C T I O N S ##################################################################### From 62aebd2a3e715b77daece2a10bb081df50576906 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 17 May 2005 11:48:02 +0000 Subject: [PATCH 023/106] Make number of accepts we perform lower if MAXCONNIP is used Make connection hook get called after we do all the accept()s git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@420 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 1 - lib/Qpsmtpd/PollServer.pm | 14 ++++++++++++-- qpsmtpd | 14 +++++++------- 3 files changed, 19 insertions(+), 10 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 95c9c2e..f91a974 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -77,7 +77,6 @@ our ( ); %OtherFds = (); -$LocalPostLoopCallback = 0; ##################################################################### ### C L A S S M E T H O D S diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 5e14362..f88d690 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -47,6 +47,7 @@ sub new { $self = fields::new($self) unless ref $self; $self->SUPER::new( @_ ); $self->{start_time} = time; + $self->{mode} = 'connect'; $self->load_plugins; return $self; } @@ -111,8 +112,17 @@ sub process_line { sub _process_line { my $self = shift; my $line = shift; - - if ($self->{mode} eq 'cmd') { + + if ($self->{mode} eq 'connect') { + warn("Connection incoming\n"); + my $rc = $self->start_conversation; + if ($rc != DONE) { + $self->close; + return; + } + $self->{mode} = 'cmd'; + } + elsif ($self->{mode} eq 'cmd') { $line =~ s/\r?\n//; return $self->process_cmd($line); } diff --git a/qpsmtpd b/qpsmtpd index 7b9f989..f69467d 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -289,10 +289,14 @@ sub config_handler { return; } +# TODO: +# - Make number of accepts() we do dependant on whether MAXCONNIP is set + # Accept all new connections sub accept_handler { - for (1..10000) { - last unless _accept_handler(); + my $max = $MAXCONNIP ? 100 : 1000; + for (1 .. $max) { + last if ! _accept_handler(); } } @@ -359,11 +363,7 @@ sub _accept_handler { $client->log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip"); } - my $rc = $client->start_conversation; - if ($rc != DONE) { - $client->close; - return 1; - } + $client->push_back_read("Connect\n"); $client->watch_read(1); return 1; } From 9432e1bac162b909698fcb51e6435e1b1826f181 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 19 May 2005 15:39:53 +0000 Subject: [PATCH 024/106] Use SOMAXCONN which makes connections MUCH happier on high load servers git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@421 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/qpsmtpd b/qpsmtpd index f69467d..f7076b5 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -27,7 +27,7 @@ $|++; # For debugging # $SIG{USR1} = sub { Carp::confess("USR1") }; -use Socket qw(IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); +use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); $SIG{'PIPE'} = "IGNORE"; # handled manually @@ -207,7 +207,7 @@ sub run_as_server { Proto => IPPROTO_TCP, Blocking => 0, Reuse => 1, - Listen => 10 ) + Listen => SOMAXCONN ) or die "Error creating server $LOCALADDR:$PORT : $@\n"; IO::Handle::blocking($SERVER, 0); @@ -289,18 +289,8 @@ sub config_handler { return; } -# TODO: -# - Make number of accepts() we do dependant on whether MAXCONNIP is set - # Accept all new connections sub accept_handler { - my $max = $MAXCONNIP ? 100 : 1000; - for (1 .. $max) { - last if ! _accept_handler(); - } -} - -sub _accept_handler { my $running; if( $LineMode ) { $running = scalar keys %childstatus; @@ -309,12 +299,22 @@ sub _accept_handler { my $descriptors = Danga::Client->DescriptorMap; $running = scalar keys %$descriptors; } - if ($running >= $MAXCONN) { - ::log(LOGINFO,"Too many connections: $running >= $MAXCONN."); - return; + + my $max = $MAXCONNIP ? 100 : 1000; + + for (1 .. $max) { + if ($running >= $MAXCONN) { + ::log(LOGINFO,"Too many connections: $running >= $MAXCONN."); + return; + } + $running++; + last if ! _accept_handler($running); } - ++$running if $LineMode; # count self +} +sub _accept_handler { + my $running = shift; + my $csock = $SERVER->accept(); if (!$csock) { # warn("accept() failed: $!"); @@ -331,7 +331,6 @@ sub _accept_handler { if (!$LineMode) { # multiplex mode my $client = Qpsmtpd::PollServer->new($csock); - my $rem_ip = $client->peer_ip_string; if ($PAUSED) { $client->write("451 Sorry, this server is currently paused\r\n"); @@ -341,7 +340,8 @@ sub _accept_handler { if ($MAXCONNIP) { my $num_conn = 1; # seed with current value - + my $rem_ip = $client->peer_ip_string; + # If we for-loop directly over values %childstatus, a SIGCHLD # can call REAPER and slip $rip out from under us. Causes # "Use of freed value in iteration" under perl 5.8.4. From ec9ddc09d247297be65f1ed00be6c17c51ed3f95 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 20 May 2005 12:39:05 +0000 Subject: [PATCH 025/106] Fix for in-memory code copying headers twice git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@422 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Transaction.pm | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index dd075de..a6dc3be 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -64,6 +64,17 @@ sub notes { sub set_body_start { my $self = shift; $self->{_body_start} = $self->body_current_pos; + if ($self->{_body_file}) { + $self->{_header_size} = $self->{_body_start}; + } + else { + $self->{_header_size} = 0; + if ($self->{_body_array}) { + foreach my $line (@{ $self->{_body_array} }) { + $self->{_header_size} += length($line); + } + } + } } sub body_start { @@ -123,6 +134,7 @@ sub body_write { foreach my $line (@{ $self->{_body_array} }) { $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; } + $self->{_body_start} = $self->{_header_size}; } $self->{_body_array} = undef; } From 3b9c5b69fd9b7d6aac8a1b6a8865d33f8e005b23 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 23 May 2005 12:59:57 +0000 Subject: [PATCH 026/106] Move PLC managment into close() and call close() in DESTROY git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@424 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index f91a974..331f357 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -374,15 +374,16 @@ sub PostEventLoop { @ToClose = (); # now we're at the very end, call per-connection callbacks if defined + my $ret = 1; # use $ret so's to not starve some FDs; return 0 if any PLCs return 0 for my $plc (values %PLCMap) { - return unless $plc->(\%DescriptorMap, \%OtherFds); + $ret &&= $plc->(\%DescriptorMap, \%OtherFds); } # now we're at the very end, call global callback if defined if (defined $PostLoopCallback) { - return $PostLoopCallback->(\%DescriptorMap, \%OtherFds); + $ret &&= $PostLoopCallback->(\%DescriptorMap, \%OtherFds); } - return 1; + return $ret; } @@ -817,7 +818,7 @@ sub SetPostLoopCallback { sub DESTROY { my Danga::Socket $self = shift; - delete $PLCMap{$self->{fd}}; + $self->close() if !$self->{closed}; } ##################################################################### From 56451a722fd00420338b6258556c521eeedf0413 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 23 May 2005 13:06:08 +0000 Subject: [PATCH 027/106] First, since EventLoop goes off and does other things, any PostLoopCallback can signal "our" EventLoop to return. To ensure we wait the full time, we must loop around until the end condition is truly satisfied. git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@425 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index 5fb002a..f85ef99 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -51,15 +51,18 @@ sub can_read { if (!length($self->{line})) { my $old = $self->watch_read(); $self->watch_read(1); - $self->SetPostLoopCallback(sub { (length($self->{line}) || - (Time::HiRes::time > $end)) ? 0 : 1 }); - #warn("get_line PRE\n"); - $self->EventLoop(); - #warn("get_line POST\n"); + # loop because any callback, not just ours, can make EventLoop return + while( !(length($self->{line}) || (Time::HiRes::time > $end)) ) { + $self->SetPostLoopCallback(sub { (length($self->{line}) || + (Time::HiRes::time > $end)) ? 0 : 1 }); + #warn("get_line PRE\n"); + $self->EventLoop(); + #warn("get_line POST\n"); + } $self->watch_read($old); } $self->{can_read_mode} = 0; - $self->SetPostLoopCallback(sub { $self->have_line ? 0 : 1 }); + $self->SetPostLoopCallback(undef); return if $self->{closing}; $self->{alive_time} = time; # warn("can_read returning for '$self->{line}'\n"); From 42e49d493a283137fb56722786085a98fcb8fa75 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 23 May 2005 14:17:43 +0000 Subject: [PATCH 028/106] Don't set an alarm if in connect mode. Make fault() not return anything otherwise we get a "1" output in the stream git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@426 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/PollServer.pm | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index f88d690..61cc7fd 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -89,6 +89,12 @@ sub respond { return 1; } +sub fault { + my $self = shift; + $self->SUPER::fault(@_); + return; +} + sub process_line { my $self = shift; my $line = shift || return; @@ -97,14 +103,19 @@ sub process_line { my ($pkg, $file, $line) = caller(); die "ALARM: ($self->{mode}) $pkg, $file, $line"; }; - my $prev = alarm(2); # must process a command in < 2 seconds - eval { $self->_process_line($line) }; - alarm($prev); - if ($@) { - print STDERR "Error: $@\n"; - return $self->fault("command failed unexpectedly") if $self->{mode} eq 'cmd'; - return $self->fault("error processing data lines") if $self->{mode} eq 'data'; - return $self->fault("unknown error"); + if( $self->{mode} eq 'connect' ) { + eval { $self->_process_line($line) } + } + else { + my $prev = alarm(2); # must process a command in < 2 seconds + eval { $self->_process_line($line) }; + alarm($prev); + if ($@) { + print STDERR "Error: $@\n"; + return $self->fault("command failed unexpectedly") if $self->{mode} eq 'cmd'; + return $self->fault("error processing data lines") if $self->{mode} eq 'data'; + return $self->fault("unknown error"); + } } return; } @@ -114,13 +125,12 @@ sub _process_line { my $line = shift; if ($self->{mode} eq 'connect') { - warn("Connection incoming\n"); + $self->{mode} = 'cmd'; my $rc = $self->start_conversation; if ($rc != DONE) { $self->close; return; } - $self->{mode} = 'cmd'; } elsif ($self->{mode} eq 'cmd') { $line =~ s/\r?\n//; From 1f036fee90297adc07b9f615bf739966365ab0ba Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 8 Jun 2005 22:24:00 +0000 Subject: [PATCH 029/106] Move the stats code purely into the plugin so that this can be extended easier. git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@429 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/ConfigServer.pm | 12 ++++++------ lib/Qpsmtpd/Stats.pm | 35 ----------------------------------- plugins/stats | 34 +++++++++++++++++++++++++++++++--- 3 files changed, 37 insertions(+), 44 deletions(-) delete mode 100644 lib/Qpsmtpd/Stats.pm diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm index fd2c8a7..7a92d64 100644 --- a/lib/Qpsmtpd/ConfigServer.pm +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -155,13 +155,13 @@ sub cmd_status { my $output = "Current Status as of " . gmtime() . " GMT\n\n"; - if ($INC{'Qpsmtpd/Stats.pm'}) { + if (defined &Qpsmtpd::Plugin::stats::register) { # Stats plugin is loaded - my $uptime = Qpsmtpd::Stats->uptime; - my $recvd = Qpsmtpd::Stats->mails_received; - my $reject = Qpsmtpd::Stats->mails_rejected; - my $soft = Qpsmtpd::Stats->mails_tempfailed; - my $rate = Qpsmtpd::Stats->mails_per_sec; + my $uptime = Qpsmtpd::Plugin::stats->uptime; + my $recvd = Qpsmtpd::Plugin::stats->mails_received; + my $reject = Qpsmtpd::Plugin::stats->mails_rejected; + my $soft = Qpsmtpd::Plugin::stats->mails_tempfailed; + my $rate = Qpsmtpd::Plugin::stats->mails_per_sec; $output .= sprintf(" Uptime: %0.2f sec\n". " Mails Received: % 10d\n". " 5xx: % 10d\n". diff --git a/lib/Qpsmtpd/Stats.pm b/lib/Qpsmtpd/Stats.pm deleted file mode 100644 index a858b9f..0000000 --- a/lib/Qpsmtpd/Stats.pm +++ /dev/null @@ -1,35 +0,0 @@ -# $Id$ - -package Qpsmtpd::Stats; - -use strict; -use Qpsmtpd; -use Qpsmtpd::Constants; -use Time::HiRes qw(time); - -my $START_TIME = time; -our $MAILS_RECEIVED = 0; -our $MAILS_REJECTED = 0; -our $MAILS_TEMPFAIL = 0; - -sub uptime { - return (time() - $START_TIME); -} - -sub mails_received { - return $MAILS_RECEIVED; -} - -sub mails_rejected { - return $MAILS_REJECTED; -} - -sub mails_tempfailed { - return $MAILS_TEMPFAIL; -} - -sub mails_per_sec { - return ($MAILS_RECEIVED / uptime()); -} - -1; \ No newline at end of file diff --git a/plugins/stats b/plugins/stats index 200cac9..1a2e1b5 100644 --- a/plugins/stats +++ b/plugins/stats @@ -1,6 +1,12 @@ #!/usr/bin/perl -w use Qpsmtpd::Stats; +use Time::HiRes qw(time); + +my $START_TIME = time; +our $MAILS_RECEIVED = 0; +our $MAILS_REJECTED = 0; +our $MAILS_TEMPFAIL = 0; sub register { my ($self) = @_; @@ -13,10 +19,10 @@ sub increment_deny { my ($self, $tran, $plugin, $level) = @_; if ($level == DENY or $level == DENY_DISCONNECT) { - $Qpsmtpd::Stats::MAILS_REJECTED++; + $MAILS_REJECTED++; } elsif ($level == DENYSOFT or $level == DENYSOFT_DISCONNECT) { - $Qpsmtpd::Stats::MAILS_TEMPFAIL++; + $MAILS_TEMPFAIL++; } return DECLINED; @@ -25,7 +31,29 @@ sub increment_deny { sub increment_mails { my $self = shift; - $Qpsmtpd::Stats::MAILS_RECEIVED++; + $MAILS_RECEIVED++; return DECLINED; } + +sub uptime { + return (time() - $START_TIME); +} + +sub mails_received { + return $MAILS_RECEIVED; +} + +sub mails_rejected { + return $MAILS_REJECTED; +} + +sub mails_tempfailed { + return $MAILS_TEMPFAIL; +} + +sub mails_per_sec { + return ($MAILS_RECEIVED / uptime()); +} + + From 9fbf25a7086dbd9e6d26624d249eab47a44e064c Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 8 Jun 2005 22:25:28 +0000 Subject: [PATCH 030/106] More of the same. git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@430 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/ConfigServer.pm | 12 +----------- plugins/stats | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm index 7a92d64..2200cb0 100644 --- a/lib/Qpsmtpd/ConfigServer.pm +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -157,17 +157,7 @@ sub cmd_status { if (defined &Qpsmtpd::Plugin::stats::register) { # Stats plugin is loaded - my $uptime = Qpsmtpd::Plugin::stats->uptime; - my $recvd = Qpsmtpd::Plugin::stats->mails_received; - my $reject = Qpsmtpd::Plugin::stats->mails_rejected; - my $soft = Qpsmtpd::Plugin::stats->mails_tempfailed; - my $rate = Qpsmtpd::Plugin::stats->mails_per_sec; - $output .= sprintf(" Uptime: %0.2f sec\n". - " Mails Received: % 10d\n". - " 5xx: % 10d\n". - " 4xx: % 10d\n". - "Mails per second: %0.2f\n", - $uptime, $recvd, $reject, $soft, $rate); + $output .= Qpsmtpd::Plugin::stats->get_stats; } my $descriptors = Danga::Socket->DescriptorMap; diff --git a/plugins/stats b/plugins/stats index 1a2e1b5..92e0f4e 100644 --- a/plugins/stats +++ b/plugins/stats @@ -15,6 +15,20 @@ sub register { $self->register_hook('queue', 'increment_mails'); } +sub get_stats { + my $uptime = Qpsmtpd::Plugin::stats->uptime; + my $recvd = Qpsmtpd::Plugin::stats->mails_received; + my $reject = Qpsmtpd::Plugin::stats->mails_rejected; + my $soft = Qpsmtpd::Plugin::stats->mails_tempfailed; + my $rate = Qpsmtpd::Plugin::stats->mails_per_sec; + return sprintf(" Uptime: %0.2f sec\n". + " Mails Received: % 10d\n". + " 5xx: % 10d\n". + " 4xx: % 10d\n". + "Mails per second: %0.2f\n", + $uptime, $recvd, $reject, $soft, $rate); +} + sub increment_deny { my ($self, $tran, $plugin, $level) = @_; From b323b33f60e19303058c65d3e0af7e1f7ee171dd Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 15 Jun 2005 20:34:34 +0000 Subject: [PATCH 031/106] More cleanup git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@433 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/stats | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/plugins/stats b/plugins/stats index 92e0f4e..fbe0119 100644 --- a/plugins/stats +++ b/plugins/stats @@ -1,6 +1,5 @@ #!/usr/bin/perl -w -use Qpsmtpd::Stats; use Time::HiRes qw(time); my $START_TIME = time; @@ -16,11 +15,12 @@ sub register { } sub get_stats { - my $uptime = Qpsmtpd::Plugin::stats->uptime; - my $recvd = Qpsmtpd::Plugin::stats->mails_received; - my $reject = Qpsmtpd::Plugin::stats->mails_rejected; - my $soft = Qpsmtpd::Plugin::stats->mails_tempfailed; - my $rate = Qpsmtpd::Plugin::stats->mails_per_sec; + my $class = shift; + my $uptime = $class->uptime; + my $recvd = $class->mails_received; + my $reject = $class->mails_rejected; + my $soft = $class->mails_tempfailed; + my $rate = $class->mails_per_sec; return sprintf(" Uptime: %0.2f sec\n". " Mails Received: % 10d\n". " 5xx: % 10d\n". @@ -67,7 +67,8 @@ sub mails_tempfailed { } sub mails_per_sec { - return ($MAILS_RECEIVED / uptime()); + my $class = shift; + return ($MAILS_RECEIVED / $class->uptime()); } From 6ed494275b8f84468a1dc7f6ab552e4a2e0d70b9 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Sat, 18 Jun 2005 18:20:49 +0000 Subject: [PATCH 032/106] Support a flag for how many connections to accept in the accept loop git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@435 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/qpsmtpd b/qpsmtpd index f7076b5..42fb28e 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl use lib "./lib"; BEGIN { @@ -44,6 +44,7 @@ my $MAXCONN = 15; # max simultaneous connections my $USER = 'smtpd'; # user to suid to my $MAXCONNIP = 5; # max simultaneous connections from one IP my $PAUSED = 0; +my $NUMACCEPT = 20; sub help { print < \$MAXCONN, 'm|max-from-ip=i' => \$MAXCONNIP, 'u|user=s' => \$USER, + 'a|accept=i' => \$NUMACCEPT, 'h|help' => \&help, ) || help(); @@ -86,6 +89,7 @@ if ($LOCALADDR =~ /^([\d\w\-.]+)$/) { $LOCALADDR = $1 } else { &help } if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help } if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &help } if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help } +if ($NUMACCEPT =~ /^(\d+)$/) { $NUMACCEPT = $1 } else { &help } $PROCS = 1 if $LineMode; # This is a bit of a hack, but we get to approximate MAXCONN stuff when we @@ -300,9 +304,7 @@ sub accept_handler { $running = scalar keys %$descriptors; } - my $max = $MAXCONNIP ? 100 : 1000; - - for (1 .. $max) { + for (1 .. $NUMACCEPT) { if ($running >= $MAXCONN) { ::log(LOGINFO,"Too many connections: $running >= $MAXCONN."); return; @@ -312,13 +314,22 @@ sub accept_handler { } } +use Errno qw(EAGAIN EWOULDBLOCK); + sub _accept_handler { my $running = shift; - + my $csock = $SERVER->accept(); if (!$csock) { # warn("accept() failed: $!"); return; + if ($! == EAGAIN || $! == EWOULDBLOCK) { + return; + } + else { + warn("accept() failed: $!"); + return 1; + } } binmode($csock, ':raw'); @@ -331,6 +342,7 @@ sub _accept_handler { if (!$LineMode) { # multiplex mode my $client = Qpsmtpd::PollServer->new($csock); + my $rem_ip = $client->peer_ip_string; if ($PAUSED) { $client->write("451 Sorry, this server is currently paused\r\n"); @@ -340,8 +352,7 @@ sub _accept_handler { if ($MAXCONNIP) { my $num_conn = 1; # seed with current value - my $rem_ip = $client->peer_ip_string; - + # If we for-loop directly over values %childstatus, a SIGCHLD # can call REAPER and slip $rip out from under us. Causes # "Use of freed value in iteration" under perl 5.8.4. @@ -426,7 +437,7 @@ sub _accept_handler { sub log { my ($level,$message) = @_; # $level not used yet. this is reimplemented from elsewhere anyway - warn("$$ $message\n"); + warn("$$ fd:? $message\n"); } sub pause { From a4517bdfa436b128578d3e8e2f662ef3b57168ad Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Sat, 18 Jun 2005 18:22:16 +0000 Subject: [PATCH 033/106] Continuation support git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@436 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 97 +++++++++++++----- lib/Qpsmtpd/Constants.pm | 19 ++-- lib/Qpsmtpd/PollServer.pm | 64 ++++-------- lib/Qpsmtpd/SMTP.pm | 211 ++++++++++++++++++++++++-------------- plugins/dnsbl | 34 +++--- 5 files changed, 257 insertions(+), 168 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 6d07d20..4bd5389 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -208,38 +208,20 @@ sub _load_plugins { sub run_hooks { my ($self, $hook) = (shift, shift); + if ($self->{_continuation}) { + die "Continuations in progress from previous hook (this is the $hook hook)"; + } my $hooks = $self->{hooks}; if ($hooks->{$hook}) { my @r; - for my $code (@{$hooks->{$hook}}) { - $self->log(LOGINFO, "running plugin ($hook):", $code->{name}); - eval { (@r) = $code->{code}->($self, $self->transaction, @_); }; - $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and next; - - !defined $r[0] - and $self->log(LOGERROR, "plugin ".$code->{name} - ."running the $hook hook returned undef!") - and next; - - if ($self->transaction) { - my $tnotes = $self->transaction->notes( $code->{name} ); - $tnotes->{"hook_$hook"}->{'return'} = $r[0] - if (!defined $tnotes || ref $tnotes eq "HASH"); - } else { - my $cnotes = $self->connection->notes( $code->{name} ); - $cnotes->{"hook_$hook"}->{'return'} = $r[0] - if (!defined $cnotes || ref $cnotes eq "HASH"); + my @local_hooks = @{$hooks->{$hook}}; + while (@local_hooks) { + my $code = shift @local_hooks; + @r = $self->run_hook($hook, $code, @_); + next unless @r; + if ($r[0] == CONTINUATION) { + $self->{_continuation} = [$hook, [@_], @local_hooks]; } - - # should we have a hook for "OK" too? - if ($r[0] == DENY or $r[0] == DENYSOFT or - $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT) - { - $r[1] = "" if not defined $r[1]; - $self->log(LOGDEBUG, "Plugin $code->{name}, hook $hook returned $r[0], $r[1]"); - $self->run_hooks("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny"); - } - last unless $r[0] == DECLINED; } $r[0] = DECLINED if not defined $r[0]; @@ -248,6 +230,65 @@ sub run_hooks { return (0, ''); } +sub finish_continuation { + my ($self) = @_; + die "No continuation in progress" unless $self->{_continuation}; + my $todo = $self->{_continuation}; + $self->{_continuation} = undef; + my $hook = shift @$todo || die "No hook in the continuation"; + my $args = shift @$todo || die "No hook args in the continuation"; + my @r; + while (@$todo) { + my $code = shift @$todo; + @r = $self->run_hook($hook, $code, @$args); + if ($r[0] == CONTINUATION) { + $self->{_continuation} = [$hook, $args, @$todo]; + return @r; + } + last unless $r[0] == DECLINED; + } + $r[0] = DECLINED if not defined $r[0]; + my $responder = $hook . "_respond"; + if (my $meth = $self->can($responder)) { + return $meth->($self, @r, @$args); + } + die "No ${hook}_respond method"; +} + +sub run_hook { + my ($self, $hook, $code, @args) = @_; + my @r; + $self->log(LOGINFO, "running plugin ($hook):", $code->{name}); + eval { (@r) = $code->{code}->($self, $self->transaction, @args); }; + $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and return; + + !defined $r[0] + and $self->log(LOGERROR, "plugin ".$code->{name} + ."running the $hook hook returned undef!") + and return; + + if ($self->transaction) { + my $tnotes = $self->transaction->notes( $code->{name} ); + $tnotes->{"hook_$hook"}->{'return'} = $r[0] + if (!defined $tnotes || ref $tnotes eq "HASH"); + } else { + my $cnotes = $self->connection->notes( $code->{name} ); + $cnotes->{"hook_$hook"}->{'return'} = $r[0] + if (!defined $cnotes || ref $cnotes eq "HASH"); + } + + # should we have a hook for "OK" too? + if ($r[0] == DENY or $r[0] == DENYSOFT or + $r[0] == DENY_DISCONNECT or $r[0] == DENYSOFT_DISCONNECT) + { + $r[1] = "" if not defined $r[1]; + $self->log(LOGDEBUG, "Plugin $code->{name}, hook $hook returned $r[0], $r[1]"); + $self->run_hooks("deny", $code->{name}, $r[0], $r[1]) unless ($hook eq "deny"); + } + + return @r; +} + sub _register_hook { my $self = shift; my ($hook, $code, $unshift) = @_; diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm index b1395eb..c67dcf4 100644 --- a/lib/Qpsmtpd/Constants.pm +++ b/lib/Qpsmtpd/Constants.pm @@ -3,7 +3,7 @@ use strict; require Exporter; my (@common) = qw(OK DECLINED DONE DENY DENYSOFT DENYHARD - DENY_DISCONNECT DENYSOFT_DISCONNECT + DENY_DISCONNECT DENYSOFT_DISCONNECT CONTINUATION ); my (@loglevels) = qw(LOGDEBUG LOGINFO LOGNOTICE LOGWARN LOGERROR LOGCRIT LOGALERT LOGEMERG LOGRADAR); @@ -11,14 +11,15 @@ use vars qw($VERSION @ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = (@common, @loglevels); -use constant OK => 900; -use constant DENY => 901; # 550 -use constant DENYSOFT => 902; # 450 -use constant DENYHARD => 903; # 550 + disconnect (deprecated in 0.29) -use constant DENY_DISCONNECT => 903; # 550 + disconnect -use constant DENYSOFT_DISCONNECT => 904; # 450 + disconnect -use constant DECLINED => 909; -use constant DONE => 910; +use constant OK => 900; +use constant DENY => 901; # 550 +use constant DENYSOFT => 902; # 450 +use constant DENYHARD => 903; # 550 + disconnect (deprecated in 0.29) +use constant DENY_DISCONNECT => 903; # 550 + disconnect +use constant DENYSOFT_DISCONNECT => 904; # 450 + disconnect +use constant DECLINED => 909; +use constant DONE => 910; +use constant CONTINUATION => 911; # log levels diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 61cc7fd..e793df5 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -21,6 +21,7 @@ use fields qw( _transaction _test_mode _extras + _continuation ); use Qpsmtpd::Constants; use Qpsmtpd::Auth; @@ -95,6 +96,13 @@ sub fault { return; } +sub log { + my ($self, $trace, @log) = @_; + my $fd = $self->{fd}; + $fd ||= '?'; + $self->SUPER::log($trace, "fd:$fd", @log); +} + sub process_line { my $self = shift; my $line = shift || return; @@ -164,17 +172,8 @@ sub process_cmd { else { # No such method - i.e. unrecognized command my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd); - if ($rc == DENY) { - $self->respond(521, $msg); - $self->disconnect; - return; - } - elsif ($rc == DONE) { - return; # TODO - this isn't right. - } - else { - return $self->respond(500, "Unrecognized command"); - } + return $self->unrecognized_command_respond unless $rc == CONTINUATION; + return 1; } } @@ -201,29 +200,20 @@ sub start_conversation { ); my ($rc, $msg) = $self->run_hooks("connect"); - if ($rc == DENY) { - $self->respond(550, ($msg || 'Connection from you denied, bye bye.')); - return $rc; - } - elsif ($rc == DENYSOFT) { - $self->respond(450, ($msg || 'Connection from you temporarily denied, bye bye.')); - return $rc; - } - elsif ($rc == DONE) { - $self->respond(220, $msg); - return $rc; - } - else { - $self->respond(220, $self->config('me') ." ESMTP qpsmtpd " - . $self->version ." ready; send us your mail, but not your spam."); - return DONE; - } + return $self->connect_respond($rc, $msg) unless $rc == CONTINUATION; + return DONE; } sub data { my $self = shift; my ($rc, $msg) = $self->run_hooks("data"); + return $self->data_respond($rc, $msg) unless $rc == CONTINUATION; + return 1; +} + +sub data_respond { + my ($self, $rc, $msg) = @_; if ($rc == DONE) { return; } @@ -350,22 +340,8 @@ sub end_of_data { return $self->respond(552, "Message too big!") if $self->{max_size} and $self->{data_size} > $self->{max_size}; my ($rc, $msg) = $self->run_hooks("data_post"); - if ($rc == DONE) { - return; - } - elsif ($rc == DENY) { - $self->respond(552, $msg || "Message denied"); - } - elsif ($rc == DENYSOFT) { - $self->respond(452, $msg || "Message denied temporarily"); - } - else { - $self->queue($self->transaction); - } - - # DATA is always the end of a "transaction" - $self->reset_transaction; - return; + return $self->data_post_respond($rc, $msg) unless $rc == CONTINUATION; + return 1; } 1; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index bb463e5..154d87f 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -54,18 +54,9 @@ sub dispatch { # if $state{dnsbl_blocked} and ($cmd eq "rcpt"); if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { - my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd); - if ($rc == DENY) { - $self->respond(521, $msg); - $self->disconnect; - } - elsif ($rc == DONE) { - 1; - } - else { - $self->respond(500, "Unrecognized command"); - } - return 1 + my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_); + return $self->unrecognized_command_respond($rc, $msg, @_) unless $rc == CONTINUATION; + return 1; } $cmd = $1; @@ -79,6 +70,17 @@ sub dispatch { return; } +sub unrecognized_command_respond { + my ($self, $rc, $msg) = @_; + if ($rc == DENY) { + $self->respond(521, $msg); + $self->disconnect; + } + elsif ($rc != DONE) { + $self->respond(500, "Unrecognized command"); + } +} + sub fault { my $self = shift; my ($msg) = shift || "program fault - command not performed"; @@ -92,6 +94,12 @@ sub start_conversation { # this should maybe be called something else than "connect", see # lib/Qpsmtpd/TcpServer.pm for more confusion. my ($rc, $msg) = $self->run_hooks("connect"); + return $self->connect_respond($rc, $msg) unless $rc == CONTINUATION; + return 1; +} + +sub connect_respond { + my ($self, $rc, $msg) = @_; if ($rc == DENY) { $self->respond(550, ($msg || 'Connection from you denied, bye bye.')); return $rc; @@ -118,17 +126,25 @@ sub helo { return $self->respond (503, "but you already said HELO ...") if $conn->hello; my ($rc, $msg) = $self->run_hooks("helo", $hello_host, @stuff); - if ($rc == DONE) { - # do nothing - } elsif ($rc == DENY) { + return $self->helo_respond($rc, $msg, $hello_host, @stuff) unless $rc == CONTINUATION; + return 1; +} + +sub helo_respond { + my ($self, $rc, $msg, $hello_host) = @_; + if ($rc == DENY) { $self->respond(550, $msg); - } elsif ($rc == DENYSOFT) { + } + elsif ($rc == DENYSOFT) { $self->respond(450, $msg); - } else { + } + elsif ($rc != DONE) { + my $conn = $self->connection; $conn->hello("helo"); $conn->hello_host($hello_host); $self->transaction; - $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]; I am so happy to meet you."); + $self->respond(250, $self->config('me') ." Hi " . $conn->remote_info . + " [" . $conn->remote_ip ."]; I am so happy to meet you."); } } @@ -140,13 +156,20 @@ sub ehlo { return $self->respond (503, "but you already said HELO ...") if $conn->hello; my ($rc, $msg) = $self->run_hooks("ehlo", $hello_host, @stuff); - if ($rc == DONE) { - # do nothing - } elsif ($rc == DENY) { + return $self->ehlo_respond($rc, $msg, $hello_host, @stuff) unless $rc == CONTINUATION; + return 1; +} + +sub ehlo_respond { + my ($self, $rc, $msg, $hello_host) = @_; + if ($rc == DENY) { $self->respond(550, $msg); - } elsif ($rc == DENYSOFT) { + } + elsif ($rc == DENYSOFT) { $self->respond(450, $msg); - } else { + } + elsif ($rc != DONE) { + my $conn = $self->connection; $conn->hello("ehlo"); $conn->hello_host($hello_host); $self->transaction; @@ -211,57 +234,62 @@ sub mail { unless ($self->connection->hello) { return $self->respond(503, "please say hello first ..."); } + + my $from_parameter = join " ", @_; + $self->log(LOGINFO, "full from_parameter: $from_parameter"); + + my ($from) = ($from_parameter =~ m/^from:\s*(<[^>]*>)/i)[0]; + + # support addresses without <> ... maybe we shouldn't? + ($from) = "<" . ($from_parameter =~ m/^from:\s*(\S+)/i)[0] . ">" + unless $from; + + $self->log(LOGWARN, "from email address : [$from]"); + + if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") { + $from = Qpsmtpd::Address->new("<>"); + } else { - my $from_parameter = join " ", @_; - $self->log(LOGINFO, "full from_parameter: $from_parameter"); + $from = (Qpsmtpd::Address->parse($from))[0]; + } + return $self->respond(501, "could not parse your mail from command") unless $from; - my ($from) = ($from_parameter =~ m/^from:\s*(<[^>]*>)/i)[0]; + my ($rc, $msg) = $self->run_hooks("mail", $from); + return $self->mail_respond($rc, $msg, $from) unless $rc == CONTINUATION; + return 1; +} - # support addresses without <> ... maybe we shouldn't? - ($from) = "<" . ($from_parameter =~ m/^from:\s*(\S+)/i)[0] . ">" - unless $from; - - $self->log(LOGWARN, "from email address : [$from]"); - - if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") { - $from = Qpsmtpd::Address->new("<>"); - } - else { - $from = (Qpsmtpd::Address->parse($from))[0]; - } - return $self->respond(501, "could not parse your mail from command") unless $from; - - my ($rc, $msg) = $self->run_hooks("mail", $from); - if ($rc == DONE) { - return 1; - } - elsif ($rc == DENY) { - $msg ||= $from->format . ', denied'; - $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); - $self->respond(550, $msg); - } - elsif ($rc == DENYSOFT) { - $msg ||= $from->format . ', temporarily denied'; - $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); - $self->respond(450, $msg); - } - elsif ($rc == DENY_DISCONNECT) { - $msg ||= $from->format . ', denied'; - $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); - $self->respond(550, $msg); - $self->disconnect; - } - elsif ($rc == DENYSOFT_DISCONNECT) { - $msg ||= $from->format . ', temporarily denied'; - $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); - $self->respond(450, $msg); - $self->disconnect; - } - else { # includes OK - $self->log(LOGINFO, "getting mail from ".$from->format); - $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); - $self->transaction->sender($from); - } +sub mail_respond { + my ($self, $rc, $msg, $from) = @_; + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $msg ||= $from->format . ', denied'; + $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); + $self->respond(550, $msg); + } + elsif ($rc == DENYSOFT) { + $msg ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); + $self->respond(450, $msg); + } + elsif ($rc == DENY_DISCONNECT) { + $msg ||= $from->format . ', denied'; + $self->log(LOGINFO, "deny mail from " . $from->format . " ($msg)"); + $self->respond(550, $msg); + $self->disconnect; + } + elsif ($rc == DENYSOFT_DISCONNECT) { + $msg ||= $from->format . ', temporarily denied'; + $self->log(LOGINFO, "denysoft mail from " . $from->format . " ($msg)"); + $self->respond(450, $msg); + $self->disconnect; + } + else { # includes OK + $self->log(LOGINFO, "getting mail from ".$from->format); + $self->respond(250, $from->format . ", sender OK - how exciting to get mail from you!"); + $self->transaction->sender($from); } } @@ -278,6 +306,12 @@ sub rcpt { return $self->respond(501, "could not parse recipient") unless $rcpt; my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt); + return $self->rcpt_respond($rc, $msg, $rcpt) unless $rc == CONTINUATION; + return 1; +} + +sub rcpt_respond { + my ($self, $rc, $msg, $rcpt) = @_; if ($rc == DONE) { return 1; } @@ -312,7 +346,6 @@ sub rcpt { } - sub help { my $self = shift; $self->respond(214, @@ -334,6 +367,12 @@ sub vrfy { # I also don't think it provides all the proper result codes. my ($rc, $msg) = $self->run_hooks("vrfy"); + return $self->vrfy_respond($rc, $msg) unless $rc == CONTINUATION; + return 1; +} + +sub vrfy_respond { + my ($self, $rc, $msg) = @_; if ($rc == DONE) { return 1; } @@ -361,6 +400,12 @@ sub rset { sub quit { my $self = shift; my ($rc, $msg) = $self->run_hooks("quit"); + return $self->quit_respond($rc, $msg) unless $rc == CONTINUATION; + return 1; +} + +sub quit_respond { + my ($self, $rc, $msg) = @_; if ($rc != DONE) { $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day."); } @@ -373,9 +418,17 @@ sub disconnect { $self->reset_transaction; } +sub disconnect_respond { } + sub data { my $self = shift; my ($rc, $msg) = $self->run_hooks("data"); + return $self->data_respond($rc, $msg) unless $rc == CONTINUATION; + return 1; +} + +sub data_respond { + my ($self, $rc, $msg) = @_; if ($rc == DONE) { return 1; } @@ -493,6 +546,11 @@ sub data { $self->respond(552, "Message too big!"),return 1 if $max_size and $size > $max_size; ($rc, $msg) = $self->run_hooks("data_post"); + return $self->data_post_respond($rc, $msg) unless $rc == CONTINUATION; +} + +sub data_post_respond { + my ($self, $rc, $msg) = @_; if ($rc == DONE) { return 1; } @@ -508,7 +566,6 @@ sub data { # DATA is always the end of a "transaction" return $self->reset_transaction; - } sub getline { @@ -524,6 +581,12 @@ sub queue { my ($self, $transaction) = @_; my ($rc, $msg) = $self->run_hooks("queue"); + return $self->queue_respond($rc, $msg) unless $rc == CONTINUATION; + return 1; +} + +sub queue_respond { + my ($self, $rc, $msg) = @_; if ($rc == DONE) { return 1; } @@ -539,8 +602,6 @@ sub queue { else { $self->respond(451, $msg || "Queuing declined or disabled; try again later" ); } - - } diff --git a/plugins/dnsbl b/plugins/dnsbl index 0a708ea..ca2c5d5 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -5,7 +5,7 @@ use Danga::DNS; sub register { my ($self) = @_; $self->register_hook("connect", "connect_handler"); - $self->register_hook("rcpt", "rcpt_handler"); + $self->register_hook("connect", "pickup_handler"); } sub connect_handler { @@ -34,12 +34,14 @@ sub connect_handler { my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); + $self->transaction->notes('pending_dns_queries', scalar(keys(%dnsbl_zones))); + my $qp = $self->qp; for my $dnsbl (keys %dnsbl_zones) { # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp if (defined($dnsbl_zones{$dnsbl})) { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background"); Danga::DNS->new( - callback => sub { $self->process_a_result($dnsbl_zones{$dnsbl}, @_) }, + callback => sub { process_a_result($qp, $dnsbl_zones{$dnsbl}, @_) }, host => "$reversed_ip.$dnsbl", type => 'A', client => $self->qp->input_sock, @@ -47,7 +49,7 @@ sub connect_handler { } else { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background"); Danga::DNS->new( - callback => sub { $self->process_txt_result(@_) }, + callback => sub { process_txt_result($qp, @_) }, host => "$reversed_ip.$dnsbl", type => 'TXT', client => $self->qp->input_sock, @@ -55,40 +57,48 @@ sub connect_handler { } } - return DECLINED; + return CONTINUATION; } sub process_a_result { - my $self = shift; - my ($template, $result, $query) = @_; + my ($qp, $template, $result, $query) = @_; + + my $pending = $qp->transaction->notes('pending_dns_queries'); + $qp->transaction->notes('pending_dns_queries', --$pending); warn("Result for A $query: $result\n"); if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { # NXDOMAIN or ERROR possibly... + $qp->finish_continuation unless $pending; return; } - my $ip = $self->connection->remote_ip; + my $conn = $qp->connection; + my $ip = $conn->remote_ip; $template =~ s/%IP%/$ip/g; - my $conn = $self->connection; $conn->notes('dnsbl', $template) unless $conn->notes('dnsbl'); + $qp->finish_continuation unless $pending; } sub process_txt_result { - my $self = shift; - my ($result, $query) = @_; + my ($qp, $result, $query) = @_; + + my $pending = $qp->transaction->notes('pending_dns_queries'); + $qp->transaction->notes('pending_dns_queries', --$pending); warn("Result for TXT $query: $result\n"); if ($result !~ /[a-z]/) { # NXDOMAIN or ERROR probably... + $qp->finish_continuation unless $pending; return; } - my $conn = $self->connection; + my $conn = $qp->connection; $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl'); + $qp->finish_continuation unless $pending; } -sub rcpt_handler { +sub pickup_handler { my ($self, $transaction, $rcpt) = @_; # RBLSMTPD being non-empty means it contains the failure message to return From cb047d9aa9d0a1ccdcd424db7b2342d29ecabc0a Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 21 Jun 2005 20:02:14 +0000 Subject: [PATCH 034/106] Timer support added to Danga::Socket check_earlytalker updated to use timers Few other code cleanups to make sure check-earlytalker is fully working git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@441 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 9 +++--- lib/Danga/DNS.pm | 10 +++---- lib/Danga/Socket.pm | 61 +++++++++++++++++++++++++++++++++++++-- lib/Qpsmtpd/PollServer.pm | 5 +--- lib/Qpsmtpd/SMTP.pm | 2 ++ plugins/check_earlytalker | 50 ++++++++++++++++++++++---------- 6 files changed, 104 insertions(+), 33 deletions(-) diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index f85ef99..2c37dc4 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -33,7 +33,7 @@ sub get_line { #warn("get_line PRE\n"); $self->EventLoop(); #warn("get_line POST\n"); - $self->watch_read(0); + $self->disable_read(); } return if $self->{closing}; # now have a line. @@ -49,8 +49,7 @@ sub can_read { # warn("Calling can-read\n"); $self->{can_read_mode} = 1; if (!length($self->{line})) { - my $old = $self->watch_read(); - $self->watch_read(1); + $self->disable_read(); # loop because any callback, not just ours, can make EventLoop return while( !(length($self->{line}) || (Time::HiRes::time > $end)) ) { $self->SetPostLoopCallback(sub { (length($self->{line}) || @@ -58,8 +57,8 @@ sub can_read { #warn("get_line PRE\n"); $self->EventLoop(); #warn("get_line POST\n"); - } - $self->watch_read($old); + } + $self->enable_read(); } $self->{can_read_mode} = 0; $self->SetPostLoopCallback(undef); diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm index f05f7de..dc8128a 100644 --- a/lib/Danga/DNS.pm +++ b/lib/Danga/DNS.pm @@ -39,25 +39,25 @@ sub new { if ($options{type}) { if ($options{type} eq 'TXT') { if (!$resolver->query_txt($self, @{$self->{hosts}})) { - $client->watch_read(1) if $client; + $client->enable_read() if $client; return; } } elsif ($options{type} eq 'A') { if (!$resolver->query($self, @{$self->{hosts}})) { - $client->watch_read(1) if $client; + $client->enable_read() if $client; return; } } elsif ($options{type} eq 'PTR') { if (!$resolver->query($self, @{$self->{hosts}})) { - $client->watch_read(1) if $client; + $client->enable_read() if $client; return; } } elsif ($options{type} eq 'MX') { if (!$resolver->query_mx($self, @{$self->{hosts}})) { - $client->watch_read(1) if $client; + $client->enable_read() if $client; return; } } @@ -67,7 +67,7 @@ sub new { } else { if (!$resolver->query($self, @{$self->{hosts}})) { - $client->watch_read(1) if $client; + $client->enable_read() if $client; return; } } diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 331f357..ef7b722 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -74,6 +74,7 @@ our ( # descriptors for the event loop to track. $PostLoopCallback, # subref to call at the end of each loop, if defined %PLCMap, # fd (num) -> PostLoopCallback + @Timers, # timers ); %OtherFds = (); @@ -110,6 +111,30 @@ sub OtherFds { return wantarray ? %OtherFds : \%OtherFds; } +sub AddTimer { + my $class = shift; + my ($secs, $coderef) = @_; + my $timeout = time + $secs; + + use Data::Dumper; $Data::Dumper::Indent=1; + + if (!@Timers || ($timeout > $Timers[-1][0])) { + push @Timers, [$timeout, $coderef]; + print STDERR Dumper(\@Timers); + return; + } + + # Now where do we insert... + for (my $i = 0; $i < @Timers; $i++) { + if ($Timers[$i][0] > $timeout) { + splice(@Timers, $i, 0, [$timeout, $coderef]); + print STDERR Dumper(\@Timers); + return; + } + } + + die "Shouldn't get here spank matt."; +} ### (CLASS) METHOD: DescriptorMap() ### Get the hash of Danga::Socket objects keyed by the file descriptor they are @@ -169,7 +194,16 @@ sub KQueueEventLoop { } while (1) { - my @ret = $KQueue->kevent(1000); + my $now = time; + # Run expired timers + while (@Timers && $Timers[0][0] <= $now) { + my $to_run = shift(@Timers); + $to_run->[1]->($now); + } + + # Get next timeout + my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; + my @ret = $KQueue->kevent($timeout * 1000); if (!@ret) { foreach my $fd ( keys %DescriptorMap ) { @@ -233,11 +267,21 @@ sub EpollEventLoop { } while (1) { + my $now = time; + # Run expired timers + while (@Timers && $Timers[0][0] <= $now) { + my $to_run = shift(@Timers); + $to_run->[1]->($now); + } + + # Get next timeout + my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; + my @events; my $i; my $evcount; # get up to 1000 events, 1000ms timeout - while ($evcount = epoll_wait($Epoll, 1000, 1000, \@events)) { + while ($evcount = epoll_wait($Epoll, 1000, $timeout * 1000, \@events)) { my @objs; EVENT: for ($i=0; $i<$evcount; $i++) { @@ -300,6 +344,16 @@ sub PollEventLoop { my Danga::Socket $pob; while (1) { + my $now = time; + # Run expired timers + while (@Timers && $Timers[0][0] <= $now) { + my $to_run = shift(@Timers); + $to_run->[1]->($now); + } + + # Get next timeout + my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; + # the following sets up @poll as a series of ($poll,$event_mask) # items, then uses IO::Poll::_poll, implemented in XS, which # modifies the array in place with the even elements being @@ -314,7 +368,7 @@ sub PollEventLoop { } return 0 unless @poll; - my $count = IO::Poll::_poll(1000, @poll); + my $count = IO::Poll::_poll($timeout * 1000, @poll); if (!$count) { foreach my $fd ( keys %DescriptorMap ) { my Danga::Socket $sock = $DescriptorMap{$fd}; @@ -481,6 +535,7 @@ sub close { } } + delete $PLCMap{$fd}; delete $DescriptorMap{$fd}; delete $PushBackSet{$fd}; diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index e793df5..0ee0eda 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -135,10 +135,7 @@ sub _process_line { if ($self->{mode} eq 'connect') { $self->{mode} = 'cmd'; my $rc = $self->start_conversation; - if ($rc != DONE) { - $self->close; - return; - } + return; } elsif ($self->{mode} eq 'cmd') { $line =~ s/\r?\n//; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 154d87f..7c4249e 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -102,10 +102,12 @@ sub connect_respond { my ($self, $rc, $msg) = @_; if ($rc == DENY) { $self->respond(550, ($msg || 'Connection from you denied, bye bye.')); + $self->disconnect; return $rc; } elsif ($rc == DENYSOFT) { $self->respond(450, ($msg || 'Connection from you temporarily denied, bye bye.')); + $self->disconnect; return $rc; } elsif ($rc == DONE) { diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 7256e88..1ead3d4 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -44,9 +44,6 @@ and terminating the SMTP connection. =cut -use warnings; -use strict; - sub register { my ($self, $qp, @args) = @_; @@ -61,29 +58,49 @@ sub register { @args, }; $self->register_hook('connect', 'connect_handler'); + $self->register_hook('connect', 'connect_post_handler'); $self->register_hook('mail', 'mail_handler') if $self->{_args}->{'defer-reject'}; + warn("check_earlytalker registered\n"); 1; } sub connect_handler { my ($self, $transaction) = @_; - if ($self->qp->can_read($self->{_args}->{'wait'})) { - $self->log(LOGNOTICE, 'remote host started talking before we said hello'); - if ($self->{_args}->{'defer-reject'}) { - $self->connection->notes('earlytalker', 1); - } - else { - my $msg = 'Connecting host started transmitting before SMTP greeting'; - return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; - return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; + warn("check early talker"); + my $qp = $self->qp; + my $conn = $qp->connection; + $qp->AddTimer($self->{_args}{'wait'}, sub { read_now($qp, $conn) }); + $qp->disable_read(); + return CONTINUATION; +} + +sub read_now { + my ($qp, $conn) = @_; + + warn("read now"); + $qp->enable_read(); + if (my $data = $qp->read(1024)) { + if (length($$data)) { + $qp->log(LOGNOTICE, 'remote host started talking before we said hello'); + $qp->push_back_read($data); + $conn->notes('earlytalker', 1); } } - else { - $self->log(LOGINFO, 'remote host said nothing spontaneous, proceeding'); - } - return DECLINED; + $qp->finish_continuation; +} + +sub connect_post_handler { + my ($self, $transaction) = @_; + + my $conn = $self->qp->connection; + return DECLINED unless $conn->notes('earlytalker'); + return DECLINED if $self->{'defer-reject'}; + my $msg = 'Connecting host started transmitting before SMTP greeting'; + return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; + return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; + return DECLINED; # assume action eq 'log' } sub mail_handler { @@ -91,6 +108,7 @@ sub mail_handler { my $msg = 'Connecting host started transmitting before SMTP greeting'; return DECLINED unless $self->connection->notes('earlytalker'); + my $msg = 'Connecting host started transmitting before SMTP greeting'; return (DENY,$msg) if $self->{_args}->{'action'} eq 'deny'; return (DENYSOFT,$msg) if $self->{_args}->{'action'} eq 'denysoft'; return DECLINED; From 5853c3a011e5539478f8a753625863ded8ae9157 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 22 Jun 2005 18:24:34 +0000 Subject: [PATCH 035/106] Cleanup Timer code git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@444 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 4 ---- 1 file changed, 4 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index ef7b722..3fe0a7c 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -116,11 +116,8 @@ sub AddTimer { my ($secs, $coderef) = @_; my $timeout = time + $secs; - use Data::Dumper; $Data::Dumper::Indent=1; - if (!@Timers || ($timeout > $Timers[-1][0])) { push @Timers, [$timeout, $coderef]; - print STDERR Dumper(\@Timers); return; } @@ -128,7 +125,6 @@ sub AddTimer { for (my $i = 0; $i < @Timers; $i++) { if ($Timers[$i][0] > $timeout) { splice(@Timers, $i, 0, [$timeout, $coderef]); - print STDERR Dumper(\@Timers); return; } } From bc3f52a3804dac80c2a0268ef1ce6e59bd723a34 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 22 Jun 2005 18:25:16 +0000 Subject: [PATCH 036/106] Push enable/disable read call into lib/Qpsmtpd.pm git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@445 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 4 ++++ plugins/check_earlytalker | 5 ----- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 4bd5389..f7cc088 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -220,6 +220,7 @@ sub run_hooks { @r = $self->run_hook($hook, $code, @_); next unless @r; if ($r[0] == CONTINUATION) { + $self->disable_read() if $self->isa('Danga::Client'); $self->{_continuation} = [$hook, [@_], @local_hooks]; } last unless $r[0] == DECLINED; @@ -233,6 +234,7 @@ sub run_hooks { sub finish_continuation { my ($self) = @_; die "No continuation in progress" unless $self->{_continuation}; + $self->enable_read() if $self->isa('Danga::Client'); my $todo = $self->{_continuation}; $self->{_continuation} = undef; my $hook = shift @$todo || die "No hook in the continuation"; @@ -242,6 +244,7 @@ sub finish_continuation { my $code = shift @$todo; @r = $self->run_hook($hook, $code, @$args); if ($r[0] == CONTINUATION) { + $self->disable_read() if $self->isa('Danga::Client'); $self->{_continuation} = [$hook, $args, @$todo]; return @r; } @@ -250,6 +253,7 @@ sub finish_continuation { $r[0] = DECLINED if not defined $r[0]; my $responder = $hook . "_respond"; if (my $meth = $self->can($responder)) { + warn("continuation finished on $self\n"); return $meth->($self, @r, @$args); } die "No ${hook}_respond method"; diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index 1ead3d4..6a9abec 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -61,26 +61,21 @@ sub register { $self->register_hook('connect', 'connect_post_handler'); $self->register_hook('mail', 'mail_handler') if $self->{_args}->{'defer-reject'}; - warn("check_earlytalker registered\n"); 1; } sub connect_handler { my ($self, $transaction) = @_; - warn("check early talker"); my $qp = $self->qp; my $conn = $qp->connection; $qp->AddTimer($self->{_args}{'wait'}, sub { read_now($qp, $conn) }); - $qp->disable_read(); return CONTINUATION; } sub read_now { my ($qp, $conn) = @_; - warn("read now"); - $qp->enable_read(); if (my $data = $qp->read(1024)) { if (length($$data)) { $qp->log(LOGNOTICE, 'remote host started talking before we said hello'); From be6b0e203c81c17065880822f4d885760fe7d965 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 22 Jun 2005 18:56:58 +0000 Subject: [PATCH 037/106] Fix a number of duh's in new code git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@446 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 88 ++++++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 46 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 3fe0a7c..278acf3 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -116,7 +116,7 @@ sub AddTimer { my ($secs, $coderef) = @_; my $timeout = time + $secs; - if (!@Timers || ($timeout > $Timers[-1][0])) { + if (!@Timers || ($timeout >= $Timers[-1][0])) { push @Timers, [$timeout, $coderef]; return; } @@ -275,59 +275,55 @@ sub EpollEventLoop { my @events; my $i; - my $evcount; - # get up to 1000 events, 1000ms timeout - while ($evcount = epoll_wait($Epoll, 1000, $timeout * 1000, \@events)) { - my @objs; - EVENT: - for ($i=0; $i<$evcount; $i++) { - my $ev = $events[$i]; - - # it's possible epoll_wait returned many events, including some at the end - # that ones in the front triggered unregister-interest actions. if we - # can't find the %sock entry, it's because we're no longer interested - # in that event. - my Danga::Socket $pob = $DescriptorMap{$ev->[0]}; - my $code; - my $state = $ev->[1]; - - # if we didn't find a Perlbal::Socket subclass for that fd, try other - # pseudo-registered (above) fds. - if (! $pob) { - if (my $code = $OtherFds{$ev->[0]}) { - $code->($state); - } - next; + my $evcount = epoll_wait($Epoll, 1000, $timeout * 1000, \@events); + + if (!$evcount) { + foreach my $fd ( keys %DescriptorMap ) { + my Danga::Socket $sock = $DescriptorMap{$fd}; + if ($sock->can('ticker')) { + $sock->ticker; } - - DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", - $ev->[0], ref($pob), $ev->[1], time); - - push @objs, [$pob, $state]; } - - foreach (@objs) { - my ($pob, $state) = @$_; - $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; - $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; - $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; - $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; - } - - return unless PostEventLoop(); - + next; } - foreach my $fd ( keys %DescriptorMap ) { - my Danga::Socket $sock = $DescriptorMap{$fd}; - if ($sock->can('ticker')) { - $sock->ticker; + my @objs; + EVENT: + for ($i=0; $i<$evcount; $i++) { + my $ev = $events[$i]; + + # it's possible epoll_wait returned many events, including some at the end + # that ones in the front triggered unregister-interest actions. if we + # can't find the %sock entry, it's because we're no longer interested + # in that event. + my Danga::Socket $pob = $DescriptorMap{$ev->[0]}; + my $code; + my $state = $ev->[1]; + + # if we didn't find a Perlbal::Socket subclass for that fd, try other + # pseudo-registered (above) fds. + if (! $pob) { + if (my $code = $OtherFds{$ev->[0]}) { + $code->($state); + } + next; } + + DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", + $ev->[0], ref($pob), $ev->[1], time); + + push @objs, [$pob, $state]; } + foreach (@objs) { + my ($pob, $state) = @$_; + $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; + $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; + $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; + $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; + } + return unless PostEventLoop(); - - print STDERR "Event loop ending; restarting.\n"; } exit 0; } From 6047477c11c612200644995c4a8a217b57422b7f Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 22 Jun 2005 19:40:57 +0000 Subject: [PATCH 038/106] Get rid of horrible ticker() stuff and replace with AddTimer calls git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@447 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 1 + lib/Danga/DNS/Resolver.pm | 34 ++++-------------------- lib/Danga/Socket.pm | 54 +++++++------------------------------- lib/Danga/TimeoutSocket.pm | 23 +++++----------- 4 files changed, 22 insertions(+), 90 deletions(-) diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index 2c37dc4..79bf106 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -113,6 +113,7 @@ sub enable_read { my Danga::Client $self = shift; $self->{disable_read}--; if ($self->{disable_read} <= 0) { + warn("read back on\n"); $self->{disable_read} = 0; $self->watch_read(1); } diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 80dec78..a06e2b7 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -47,6 +47,8 @@ sub new { $self->watch_read(1); + $self->AddTimer(5, sub { $self->_do_cleanup }); + return $self; } @@ -101,12 +103,6 @@ sub query_txt { $self->_query($asker, $host, 'TXT', $now) || return; } - # run cleanup every 5 seconds - if ($now - 5 > $last_cleanup) { - $last_cleanup = $now; - $self->_do_cleanup($now); - } - #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; @@ -125,12 +121,6 @@ sub query_mx { $self->_query($asker, $host, 'MX', $now) || return; } - # run cleanup every 5 seconds - if ($now - 5 > $last_cleanup) { - $last_cleanup = $now; - $self->_do_cleanup($now); - } - #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; @@ -149,31 +139,17 @@ sub query { $self->_query($asker, $host, 'A', $now) || return; } - # run cleanup every 5 seconds - if ($now - 5 > $last_cleanup) { - $last_cleanup = $now; - $self->_do_cleanup($now); - } - #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; return 1; } -sub ticker { - my Danga::DNS::Resolver $self = shift; - my $now = time; - # run cleanup every 5 seconds - if ($now - 5 > $last_cleanup) { - $last_cleanup = $now; - $self->_do_cleanup($now); - } -} - sub _do_cleanup { my Danga::DNS::Resolver $self = shift; - my $now = shift; + my $now = time; + + $self->AddTimer(5, sub { $self->_do_cleanup }); my $idle = $self->max_idle_time; diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 278acf3..a57c3dd 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -201,17 +201,6 @@ sub KQueueEventLoop { my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; my @ret = $KQueue->kevent($timeout * 1000); - if (!@ret) { - foreach my $fd ( keys %DescriptorMap ) { - my Danga::Socket $sock = $DescriptorMap{$fd}; - if ($sock->can('ticker')) { - $sock->ticker; - } - } - } - - my @objs; - foreach my $kev (@ret) { my ($fd, $filter, $flags, $fflags) = @$kev; @@ -222,20 +211,16 @@ sub KQueueEventLoop { if (my $code = $OtherFds{$fd}) { $code->($filter); } + else { + print STDERR "kevent() returned fd $fd for which we have no mapping. removing.\n"; + POSIX::close($fd); # close deletes the kevent entry + } next; } DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", $fd, ref($pob), $flags, time); - push @objs, [$pob, $filter, $flags, $fflags]; - } - - # TODO - prioritize the objects - - foreach (@objs) { - my ($pob, $filter, $flags, $fflags) = @$_; - $pob->event_read if $filter == IO::KQueue::EVFILT_READ() && !$pob->{closed}; $pob->event_write if $filter == IO::KQueue::EVFILT_WRITE() && !$pob->{closed}; if ($flags == IO::KQueue::EV_EOF() && !$pob->{closed}) { @@ -277,17 +262,6 @@ sub EpollEventLoop { my $i; my $evcount = epoll_wait($Epoll, 1000, $timeout * 1000, \@events); - if (!$evcount) { - foreach my $fd ( keys %DescriptorMap ) { - my Danga::Socket $sock = $DescriptorMap{$fd}; - if ($sock->can('ticker')) { - $sock->ticker; - } - } - next; - } - - my @objs; EVENT: for ($i=0; $i<$evcount; $i++) { my $ev = $events[$i]; @@ -306,17 +280,18 @@ sub EpollEventLoop { if (my $code = $OtherFds{$ev->[0]}) { $code->($state); } + else { + my $fd = $ev->[0]; + print STDERR "epoll() returned fd $fd w/ state $state for which we have no mapping. removing.\n"; + POSIX::close($fd); + epoll_ctl($Epoll, EPOLL_CTL_DEL, $fd, 0); + } next; } DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", $ev->[0], ref($pob), $ev->[1], time); - push @objs, [$pob, $state]; - } - - foreach (@objs) { - my ($pob, $state) = @$_; $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; @@ -361,15 +336,6 @@ sub PollEventLoop { return 0 unless @poll; my $count = IO::Poll::_poll($timeout * 1000, @poll); - if (!$count) { - foreach my $fd ( keys %DescriptorMap ) { - my Danga::Socket $sock = $DescriptorMap{$fd}; - if ($sock->can('ticker')) { - $sock->ticker; - } - } - next; - } # Fetch handles with read events while (@poll) { diff --git a/lib/Danga/TimeoutSocket.pm b/lib/Danga/TimeoutSocket.pm index c9468d2..d977570 100644 --- a/lib/Danga/TimeoutSocket.pm +++ b/lib/Danga/TimeoutSocket.pm @@ -7,6 +7,8 @@ use fields qw(alive_time create_time); our $last_cleanup = 0; +Danga::Socket->AddTimer(15, \&_do_cleanup); + sub new { my Danga::TimeoutSocket $self = shift; my $sock = shift; @@ -16,31 +18,18 @@ sub new { my $now = time; $self->{alive_time} = $self->{create_time} = $now; - if ($now - 15 > $last_cleanup) { - $last_cleanup = $now; - _do_cleanup($now); - } - return $self; } -sub ticker { - my Danga::TimeoutSocket $self = shift; - - my $now = time; - - if ($now - 15 > $last_cleanup) { - $last_cleanup = $now; - _do_cleanup($now); - } -} - # overload these in a subclass sub max_idle_time { 0 } sub max_connect_time { 0 } sub _do_cleanup { - my $now = shift; + my $now = time; + + Danga::Socket->AddTimer(15, \&_do_cleanup); + my $sf = __PACKAGE__->get_sock_ref; my %max_age; # classname -> max age (0 means forever) From a4a62af8478e25271a21ad44f0fb438ef0e78d3b Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 23 Jun 2005 12:27:38 +0000 Subject: [PATCH 039/106] Port to CONTINUATIONS style git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@449 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/require_resolvable_fromhost | 48 +++++++++++++++++++---------- 1 file changed, 31 insertions(+), 17 deletions(-) diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index 007e8bf..a587bb5 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -11,9 +11,9 @@ sub register { sub mail_handler { my ($self, $transaction, $sender) = @_; - $sender->format ne "<>" and $self->check_dns($sender->host); - - return DECLINED; + $self->transaction->notes('resolvable', 1); + return DECLINED if $sender->format eq "<>"; + return $self->check_dns($sender->host); } @@ -21,42 +21,56 @@ sub check_dns { my ($self, $host) = @_; # for stuff where we can't even parse a hostname out of the address - return unless $host; - - return $self->transaction->notes('resolvable', 1) - if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/; + return DECLINED unless $host; + if( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) { + $self->transaction->notes('resolvable', 1); + return DECLINED; + } + + $self->transaction->notes('pending_dns_queries', 2); + my $qp = $self->qp; + $self->log(LOGDEBUG, "Checking $host for MX record in the background"); Danga::DNS->new( - callback => sub { $self->dns_result(@_) }, + callback => sub { dns_result($qp, @_) }, host => $host, type => "MX", - client => $self->qp->input_sock, + client => $qp->input_sock, ); + $self->log(LOGDEBUG, "Checking $host for A record in the background"); Danga::DNS->new( - callback => sub { $self->dns_result(@_) }, + callback => sub { dns_result($qp, @_) }, host => $host, - client => $self->qp->input_sock, + client => $qp->input_sock, ); + return CONTINUATION; } + sub dns_result { - my ($self, $result, $query) = @_; + my ($qp, $result, $query) = @_; + my $pending = $qp->transaction->notes('pending_dns_queries'); + $qp->transaction->notes('pending_dns_queries', --$pending); + if ($result =~ /^[A-Z]+$/) { # probably an error - $self->log(LOGDEBUG, "DNS error: $result looking up $query"); - return; + $qp->log(LOGDEBUG, "DNS error: $result looking up $query"); + } else { + $qp->transaction->notes('resolvable', 1); + $qp->log(LOGDEBUG, "DNS lookup $query returned: $result"); } - - $self->log(LOGDEBUG, "DNS lookup $query returned: $result"); - $self->transaction->notes('resolvable', 1); + + $qp->finish_continuation unless $pending; } + sub rcpt_handler { my ($self, $transaction) = @_; if (!$transaction->notes('resolvable')) { my $sender = $transaction->sender; + $self->log(LOGDEBUG, "Could not resolve " .$sender->host) if $sender->host; return (DENYSOFT, ($sender->host ? "Could not resolve ". $sender->host From a268ec079a33deac259c7bfefe7c43fe9e58e430 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 23 Jun 2005 21:05:44 +0000 Subject: [PATCH 040/106] Make _respond methods work when only one value is returned git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@450 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index f7cc088..e3f3e3c 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -254,7 +254,7 @@ sub finish_continuation { my $responder = $hook . "_respond"; if (my $meth = $self->can($responder)) { warn("continuation finished on $self\n"); - return $meth->($self, @r, @$args); + return $meth->($self, $r[0], $r[1], @$args); } die "No ${hook}_respond method"; } From 1f98f22376dffb1c6e49b9a180916b67e41cd518 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 23 Jun 2005 21:11:54 +0000 Subject: [PATCH 041/106] Fix for when pipelining occurs we need to shift the pre-read data back onto the socket and let the socket loop come back to this socket's data later. git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@451 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 13 ++++++++++++- lib/Danga/Socket.pm | 11 +++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index 79bf106..74a3334 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -90,7 +90,7 @@ sub process_read_buf { my Danga::Client $self = shift; my $bref = shift; $self->{line} .= $$bref; - return if $self->{can_read_mode}; + return if ! $self->readable(); return if $::LineMode; while ($self->{line} =~ s/^(.*?\n)//) { @@ -100,7 +100,18 @@ sub process_read_buf { if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) } $self->write($resp) if $resp; $self->watch_read(0) if $self->{disable_read}; + last if ! $self->readable(); } + if($self->have_line) { + $self->shift_back_read($self->{line}); + $self->{line} = ''; + } +} + +sub readable { + my Danga::Client $self = shift; + return 0 if $self->{disable_read} > 0; + return 1; } sub disable_read { diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index a57c3dd..289cd60 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -636,6 +636,17 @@ sub push_back_read { $PushBackSet{$self->{fd}} = $self; } +### METHOD: shift_back_read( $buf ) +### Shift back I (a scalar or scalarref) into the read stream +### Use this instead of push_back_read() when you need to unread +### something you just read. +sub shift_back_read { + my Danga::Socket $self = shift; + my $buf = shift; + unshift @{$self->{read_push_back}}, ref $buf ? $buf : \$buf; + $PushBackSet{$self->{fd}} = $self; +} + ### METHOD: read( $bytecount ) ### Read at most I bytes from the underlying handle; returns scalar ### ref on read, or undef on connection closed. From 1c22628118f67ab9fcd754cae6a997d0996f4c6e Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 24 Jun 2005 16:07:48 +0000 Subject: [PATCH 042/106] Automatically ramp up the number of connections we accept when under heavy load git-svn-id: https://svn.perl.org/qpsmtpd/branches/high_perf@452 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/qpsmtpd b/qpsmtpd index 42fb28e..84b7760 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -90,6 +90,7 @@ if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &help } if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &help } if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help } if ($NUMACCEPT =~ /^(\d+)$/) { $NUMACCEPT = $1 } else { &help } +my $_NUMACCEPT = $NUMACCEPT; $PROCS = 1 if $LineMode; # This is a bit of a hack, but we get to approximate MAXCONN stuff when we @@ -310,8 +311,16 @@ sub accept_handler { return; } $running++; - last if ! _accept_handler($running); + if (! _accept_handler($running)) { + # got here because we have too many accepts. + $NUMACCEPT = $_NUMACCEPT; + return; + } } + + # got here because we have accept's left. + # So double the number we accept next time. + $NUMACCEPT *= 2; } use Errno qw(EAGAIN EWOULDBLOCK); From ae99e6e3f21d775f4632f53a8d467e2bffb781c8 Mon Sep 17 00:00:00 2001 From: Robert Spier Date: Fri, 8 Jul 2005 03:37:09 +0000 Subject: [PATCH 043/106] r491@dog: rspier | 2005-07-07 20:32:53 -0700 fix isa_plugins typo git-svn-id: https://svn.perl.org/qpsmtpd/trunk@486 958fd67b-6ff1-0310-b445-bb7760255be9 --- README.plugins | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.plugins b/README.plugins index 57b7f88..81eaa63 100644 --- a/README.plugins +++ b/README.plugins @@ -333,7 +333,7 @@ loaded. It's mostly for inheritance, below. =head1 Inheritance Instead of modifying @ISA directly in your plugin, use the -C< plugin_isa > method from the init subroutine. +C< isa_plugin > method from the C< init > subroutine. # rcpt_ok_child sub init { From 812771ad1675aef29117fa4dcbec00daf3f1657d Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 8 Jul 2005 13:06:15 +0000 Subject: [PATCH 044/106] Don't use exists() on a method call. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@487 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/greylisting | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/greylisting b/plugins/greylisting index 2c9c412..89df1bc 100644 --- a/plugins/greylisting +++ b/plugins/greylisting @@ -184,7 +184,7 @@ sub denysoft_greylist { $self->log(LOGDEBUG, "config: " . join(',',map { $_ . '=' . $config->{$_} } sort keys %$config)); # Always allow relayclients and whitelisted hosts/senders - return DECLINED if exists $self->qp->connection->relay_client(); + return DECLINED if $self->qp->connection->relay_client(); return DECLINED if $self->qp->connection->notes('whitelisthost'); return DECLINED if $transaction->notes('whitelistsender'); From fac8cd7a30ba0239db7f0b4864375c86e09529a5 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 8 Jul 2005 16:43:37 +0000 Subject: [PATCH 045/106] TLS plugin git-svn-id: https://svn.perl.org/qpsmtpd/trunk@488 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 135 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 135 insertions(+) create mode 100644 plugins/tls diff --git a/plugins/tls b/plugins/tls new file mode 100644 index 0000000..8406f76 --- /dev/null +++ b/plugins/tls @@ -0,0 +1,135 @@ +#!perl -w + +=head1 NAME + +tls - plugin to support STARTTLS + +=head1 SYNOPSIS + +# in config/plugins + + tls ssl/cert.pem ssl/privkey.pem + +=head1 DESCRIPTION + +This plugin implements basic TLS support. + +If TLS is successfully negotiated then the C field in the +Connection notes is set. If you wish to make TLS mandatory you should check +that field and take appropriate action. Note that you can only do that from +MAIL FROM onwards. + +=cut + +use IO::Socket::SSL qw(debug1 debug2 debug3 debug4); + +sub init { + my ($self, $qp, $cert, $key) = @_; + $cert ||= 'ssl/cert.pem'; + $key ||= 'ssl/privkey.pem'; + $self->tls_cert($cert); + $self->tls_key($key); + + local $^W; # this bit is very noisy... + my $ssl_ctx = IO::Socket::SSL::SSL_Context->new( + SSL_use_cert => 1, + SSL_cert_file => $self->tls_cert, + SSL_key_file => $self->tls_key, + SSL_cipher_list => 'HIGH', + SSL_server => 1 + ) or die "Could not create SSL context: $!"; + # now extract the password... + + $self->ssl_context($ssl_ctx); +} + +sub hook_ehlo { + my ($self, $transaction) = @_; + return DECLINED unless $self->can_do_tls; + return DECLINED if $self->connection->notes('tls_enabled'); + return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); + my $cap = $transaction->notes('capabilities'); + $cap ||= []; + push @$cap, 'STARTTLS'; + $transaction->notes('tls_enabled', 1); + $transaction->notes('capabilities', $cap); + return DECLINED; +} + +sub hook_unrecognized_command { + my ($self, $transaction, $cmd, @args) = @_; + return DECLINED unless $cmd eq 'starttls'; + return DECLINED unless $transaction->notes('tls_enabled'); + return DENY, "Syntax error (no parameters allowed)" if @args; + + # OK, now we setup TLS + $self->qp->respond (220, "Go ahead with TLS"); + + eval { + my $tlssocket = IO::Socket::SSL->new_from_fd( + fileno(STDIN), '+>', + SSL_use_cert => 1, + SSL_cert_file => $self->tls_cert, + SSL_key_file => $self->tls_key, + SSL_cipher_list => 'HIGH', + SSL_server => 1, + SSL_reuse_ctx => $self->ssl_context, + ) or die "Could not create SSL socket: $!"; + + my $conn = $self->connection; + # Create a new connection object with subset of information collected thus far + $self->qp->connection(Qpsmtpd::Connection->new( + map { $_ => $conn->$_ } + qw( + local_ip + local_port + remote_ip + remote_port + remote_host + remote_info + ), + )); + $self->qp->reset_transaction; + *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket); + $self->connection->notes('tls_enabled', 1); + }; + if ($@) { + # SSL setup failed. Now we must respond to every command with 5XX + warn("TLS failed: $@\n"); + $transaction->notes('ssl_failed', 1); + return DENY, "TLS Negotiation Failed"; + } + + warn("TLS setup returning\n"); + return DONE; +} + +sub can_do_tls { + my ($self) = @_; + $self->tls_cert && -r $self->tls_cert; +} + +sub tls_cert { + my $self = shift; + @_ and $self->{_tls_cert} = shift; + $self->{_tls_cert}; +} + +sub tls_key { + my $self = shift; + @_ and $self->{_tls_key} = shift; + $self->{_tls_key}; +} + +sub ssl_context { + my $self = shift; + @_ and $self->{_ssl_ctx} = shift; + $self->{_ssl_ctx}; +} + +# Fulfill RFC 2487 secn 5.1 +sub bad_ssl_hook { + my ($self, $transaction) = @_; + return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); +} +*hook_helo = *hook_data = *hook_rcpt = *hook_mail = *hook_auth = \&bad_ssl_hook; From 00c53652c99b58c496efe29b1c5cde3214b04435 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sat, 9 Jul 2005 11:03:53 +0000 Subject: [PATCH 046/106] r547@jpeacock: jpeacock | 2005-07-02 07:20:17 -0400 Replace pithy comment with something more neutral. Thanks Gordon Rowell r548@jpeacock: jpeacock | 2005-07-02 07:24:21 -0400 Example patterns for badrcptto plugin - Gordon Rowell r586@jpeacock: jpeacock | 2005-07-09 06:54:47 -0400 Don't use varlog() directly unless you are passing all parameters. Don't try to log() anything during loading of logging plugins. r587@jpeacock: jpeacock | 2005-07-09 06:59:57 -0400 Cannot use new-style hooking with logging plugins (yet). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@490 958fd67b-6ff1-0310-b445-bb7760255be9 --- config.sample/badrcptto_patterns | 5 +++++ lib/Qpsmtpd/Plugin.pm | 3 ++- plugins/check_spamhelo | 2 +- plugins/logging/adaptive | 10 +++++++--- plugins/logging/devnull | 8 +++++++- plugins/logging/warn | 3 ++- 6 files changed, 24 insertions(+), 7 deletions(-) create mode 100644 config.sample/badrcptto_patterns diff --git a/config.sample/badrcptto_patterns b/config.sample/badrcptto_patterns new file mode 100644 index 0000000..e3bdca9 --- /dev/null +++ b/config.sample/badrcptto_patterns @@ -0,0 +1,5 @@ +# Format is pattern\s+Response +# Don't forget to anchor the pattern if required +! Sorry, bang paths not accepted here +@.*@ Sorry, multiple at signs not accepted here +% Sorry, percent hack not accepted here diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index d3200ff..23a0996 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -20,7 +20,8 @@ sub register_hook { die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook}; - $plugin->{_qp}->varlog(LOGDEBUG, $plugin->plugin_name, " hooking ", $hook); + $plugin->{_qp}->log(LOGDEBUG, $plugin->plugin_name, "hooking", $hook) + unless $hook =~ /logging/; # can't log during load_logging() # I can't quite decide if it's better to parse this code ref or if # we should pass the plugin object and method name ... hmn. diff --git a/plugins/check_spamhelo b/plugins/check_spamhelo index 2461460..fb90b72 100644 --- a/plugins/check_spamhelo +++ b/plugins/check_spamhelo @@ -23,7 +23,7 @@ sub hook_helo { for my $bad ($self->qp->config('badhelo')) { if ($host eq lc $bad) { $self->log(LOGDEBUG, "Denying HELO from host claiming to be $bad"); - return (DENY, "Uh-huh. You're $host, and I'm a boil on the bottom of the Marquess of Queensbury's great-aunt."); + return (DENY, "Sorry, I don't believe that you are $host."); } } return DECLINED; diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 4e57801..2964d90 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -30,12 +30,16 @@ sub register { $self->{_prefix} = $1; } + $self->register_hook( 'logging', 'wlog' ); + $self->register_hook( 'deny', 'dlog' ); + $self->register_hook( 'reset_transaction', 'slog' ); + # If you want to capture this log entry with this plugin, you need to # wait until after you register the plugin $self->log( LOGINFO, 'Initializing logging::adaptive plugin' ); } -sub hook_logging { # wlog +sub wlog { my ( $self, $transaction, $trace, $hook, $plugin, @log ) = @_; # Don't log your own log entries! If this is the only logging plugin @@ -62,12 +66,12 @@ sub hook_logging { # wlog return DECLINED; } -sub hook_deny { # dlog +sub dlog { my ( $self, $transaction, $prev_hook, $return, $return_text ) = @_; $self->{_denied} = 1; } -sub hook_reset_transaction { # slog +sub slog { # fires when a message is accepted my ( $self, $transaction, @args ) = @_; diff --git a/plugins/logging/devnull b/plugins/logging/devnull index 566ab68..33d524e 100644 --- a/plugins/logging/devnull +++ b/plugins/logging/devnull @@ -1,7 +1,13 @@ #!/usr/bin/perl # this is a simple 'drop packets on the floor' plugin -sub hook_logging { +sub register { + my $self = shift; + + $self->register_hook('logging', 'wlog'); +} + +sub wlog { return DECLINED; } diff --git a/plugins/logging/warn b/plugins/logging/warn index ce25399..4c79ddd 100644 --- a/plugins/logging/warn +++ b/plugins/logging/warn @@ -16,13 +16,14 @@ sub register { $self->{_level} = log_level($loglevel); } } + $self->register_hook('logging', 'wlog'); # If you want to capture this log entry with this plugin, you need to # wait until after you register the plugin $self->log(LOGINFO,'Initializing logging::warn plugin'); } -sub hook_logging { +sub wlog { my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; # Don't log your own log entries! If this is the only logging plugin From 1f7ece38f2df56066067065bd8df0d05c70eeb57 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sun, 10 Jul 2005 10:56:55 +0000 Subject: [PATCH 047/106] r589@jpeacock: jpeacock | 2005-07-10 06:54:32 -0400 Track hooks as array and hash. Re-revert changes to logging plugins to use new-style hooking. logging/adaptive assumed that register() has been called before hook_logging. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@491 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Plugin.pm | 9 +++++---- plugins/logging/adaptive | 16 ++++++---------- plugins/logging/devnull | 8 +------- plugins/logging/warn | 3 +-- 4 files changed, 13 insertions(+), 23 deletions(-) diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 23a0996..48f3a43 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -2,12 +2,13 @@ package Qpsmtpd::Plugin; use Qpsmtpd::Constants; use strict; -our %hooks = map { $_ => 1 } qw( - config queue data data_post quit rcpt mail ehlo helo +our @hooks = qw( + logging config queue data data_post quit rcpt mail ehlo helo auth auth-plain auth-login auth-cram-md5 connect reset_transaction unrecognized_command disconnect - deny logging ok pre-connection post-connection + deny ok pre-connection post-connection ); +our %hooks = map { $_ => 1 } @hooks; sub new { my $proto = shift; @@ -155,7 +156,7 @@ sub compile { sub _register_standard_hooks { my ($plugin, $qp) = @_; - for my $hook (keys %hooks) { + for my $hook (@hooks) { my $hooksub = "hook_$hook"; $hooksub =~ s/\W/_/g; $plugin->register_hook( $hook, $hooksub ) diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 2964d90..27d0eba 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!perl # Adaptive logging plugin - logs at one level for successful messages and # one level for DENY'd messages @@ -30,16 +30,12 @@ sub register { $self->{_prefix} = $1; } - $self->register_hook( 'logging', 'wlog' ); - $self->register_hook( 'deny', 'dlog' ); - $self->register_hook( 'reset_transaction', 'slog' ); - # If you want to capture this log entry with this plugin, you need to # wait until after you register the plugin $self->log( LOGINFO, 'Initializing logging::adaptive plugin' ); } -sub wlog { +sub hook_logging { # wlog my ( $self, $transaction, $trace, $hook, $plugin, @log ) = @_; # Don't log your own log entries! If this is the only logging plugin @@ -47,7 +43,7 @@ sub wlog { # out this line and it will not cause an infinite loop. return DECLINED if defined $plugin and $plugin eq $self->plugin_name; - if ( $trace <= $self->{_maxlevel} ) { + if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) { warn join( " ", $$. ( @@ -60,18 +56,18 @@ sub wlog { "\n" unless $log[0] =~ /logging::adaptive/; push @{ $transaction->{_log} }, [ $trace, $hook, $plugin, @log ] - if ( $trace <= $self->{_minlevel} ); + if ( defined $self->{_minlevel} && $trace <= $self->{_minlevel} ); } return DECLINED; } -sub dlog { +sub hook_deny { # dlog my ( $self, $transaction, $prev_hook, $return, $return_text ) = @_; $self->{_denied} = 1; } -sub slog { +sub hook_reset_transaction { # slog # fires when a message is accepted my ( $self, $transaction, @args ) = @_; diff --git a/plugins/logging/devnull b/plugins/logging/devnull index 33d524e..566ab68 100644 --- a/plugins/logging/devnull +++ b/plugins/logging/devnull @@ -1,13 +1,7 @@ #!/usr/bin/perl # this is a simple 'drop packets on the floor' plugin -sub register { - my $self = shift; - - $self->register_hook('logging', 'wlog'); -} - -sub wlog { +sub hook_logging { return DECLINED; } diff --git a/plugins/logging/warn b/plugins/logging/warn index 4c79ddd..ce25399 100644 --- a/plugins/logging/warn +++ b/plugins/logging/warn @@ -16,14 +16,13 @@ sub register { $self->{_level} = log_level($loglevel); } } - $self->register_hook('logging', 'wlog'); # If you want to capture this log entry with this plugin, you need to # wait until after you register the plugin $self->log(LOGINFO,'Initializing logging::warn plugin'); } -sub wlog { +sub hook_logging { my ($self, $transaction, $trace, $hook, $plugin, @log) = @_; # Don't log your own log entries! If this is the only logging plugin From 58cce1ab30325c1a0b08234575b95f339ad35c44 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 10 Jul 2005 11:38:40 +0000 Subject: [PATCH 048/106] Clean up PID file on exit, if enabled git-svn-id: https://svn.perl.org/qpsmtpd/trunk@492 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 5971e52..c89b8ef 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -23,7 +23,7 @@ my $PORT = 2525; # port number my @LOCALADDR; # ip address(es) to bind to my $USER = 'smtpd'; # user to suid to my $MAXCONNIP = 5; # max simultaneous connections from one IP -my $PID_FILE = ''; +my $PID_FILE = ''; # file to which server PID will be written sub usage { print <<"EOT"; @@ -78,6 +78,9 @@ sub REAPER { sub HUNTSMAN { $SIG{CHLD} = 'DEFAULT'; kill 'INT' => keys %childstatus; + if ($PID_FILE && -e $PID_FILE) { + unlink $PID_FILE or ::log(LOGERROR, "unlink: $PID_FILE: $!"); + } exit(0); } From 20154f7094e713ddfd878f6141ee0ea9375019f1 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 10 Jul 2005 11:46:15 +0000 Subject: [PATCH 049/106] If the PID file already exists at startup, truncate to zero-length before attempting to re-use it. Otherwise if the new PID is shorter than the previous one the file will be corrupted by the rewrite (harmlessly the way it is being read by this code, but problematically for anything that expects to be able to run something similar to /bin/kill `cat /path/to/pid.file`) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@493 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 2 ++ 1 file changed, 2 insertions(+) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index c89b8ef..9bb89be 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -116,6 +116,8 @@ if ($PID_FILE) { } seek PID, 0, 0 or die "Could not seek back to beginning of $PID_FILE: $!\n"; + truncate PID, 0 + or die "Could not truncate $PID_FILE at 0: $!"; } else { open PID, ">$PID_FILE" or die "open pid_file: $!\n"; From e407e8b470fce487fc7ae2810a34a7b8354531e2 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 11 Jul 2005 19:11:11 +0000 Subject: [PATCH 050/106] MERGE r386:r480 FROM https://svn.perl.org/qpsmtpd/branches/high_perf High perf branch merge and fixes git-svn-id: https://svn.perl.org/qpsmtpd/trunk@497 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 147 ++++++ lib/Danga/DNS.pm | 170 +++++++ lib/Danga/DNS/Resolver.pm | 307 +++++++++++++ lib/Danga/Socket.pm | 899 +++++++++++++++++++++++++++++++++++++ lib/Danga/TimeoutSocket.pm | 62 +++ 5 files changed, 1585 insertions(+) create mode 100644 lib/Danga/Client.pm create mode 100644 lib/Danga/DNS.pm create mode 100644 lib/Danga/DNS/Resolver.pm create mode 100644 lib/Danga/Socket.pm create mode 100644 lib/Danga/TimeoutSocket.pm diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm new file mode 100644 index 0000000..9e4d64a --- /dev/null +++ b/lib/Danga/Client.pm @@ -0,0 +1,147 @@ +# $Id: Client.pm,v 1.8 2005/02/14 22:06:38 msergeant Exp $ + +package Danga::Client; +use base 'Danga::TimeoutSocket'; +use fields qw(line closing disable_read can_read_mode); +use Time::HiRes (); + +# 30 seconds max timeout! +sub max_idle_time { 30 } +sub max_connect_time { 1200 } + +sub new { + my Danga::Client $self = shift; + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + + $self->reset_for_next_message; + return $self; +} + +sub reset_for_next_message { + my Danga::Client $self = shift; + $self->{line} = ''; + $self->{disable_read} = 0; + $self->{can_read_mode} = 0; + return $self; +} + +sub get_line { + my Danga::Client $self = shift; + if (!$self->have_line) { + $self->SetPostLoopCallback(sub { $self->have_line ? 0 : 1 }); + #warn("get_line PRE\n"); + $self->EventLoop(); + #warn("get_line POST\n"); + $self->disable_read(); + } + return if $self->{closing}; + # now have a line. + $self->{alive_time} = time; + $self->{line} =~ s/^(.*?\n)//; + return $1; +} + +sub can_read { + my Danga::Client $self = shift; + my ($timeout) = @_; + my $end = Time::HiRes::time() + $timeout; + # warn("Calling can-read\n"); + $self->{can_read_mode} = 1; + if (!length($self->{line})) { + $self->disable_read(); + # loop because any callback, not just ours, can make EventLoop return + while( !(length($self->{line}) || (Time::HiRes::time > $end)) ) { + $self->SetPostLoopCallback(sub { (length($self->{line}) || + (Time::HiRes::time > $end)) ? 0 : 1 }); + #warn("get_line PRE\n"); + $self->EventLoop(); + #warn("get_line POST\n"); + } + $self->enable_read(); + } + $self->{can_read_mode} = 0; + $self->SetPostLoopCallback(undef); + return if $self->{closing}; + $self->{alive_time} = time; + # warn("can_read returning for '$self->{line}'\n"); + return 1 if length($self->{line}); + return; +} + +sub have_line { + my Danga::Client $self = shift; + return 1 if $self->{closing}; + if ($self->{line} =~ /\n/) { + return 1; + } + return 0; +} + +sub event_read { + my Danga::Client $self = shift; + my $bref = $self->read(8192); + return $self->close($!) unless defined $bref; + # $self->watch_read(0); + $self->process_read_buf($bref); +} + +sub process_read_buf { + my Danga::Client $self = shift; + my $bref = shift; + $self->{line} .= $$bref; + return if ! $self->readable(); + return if $::LineMode; + + while ($self->{line} =~ s/^(.*?\n)//) { + my $line = $1; + $self->{alive_time} = time; + my $resp = $self->process_line($line); + if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) } + $self->write($resp) if $resp; + $self->watch_read(0) if $self->{disable_read}; + last if ! $self->readable(); + } + if($self->have_line) { + $self->shift_back_read($self->{line}); + $self->{line} = ''; + } +} + +sub readable { + my Danga::Client $self = shift; + return 0 if $self->{disable_read} > 0; + return 1; +} + +sub disable_read { + my Danga::Client $self = shift; + $self->{disable_read}++; + $self->watch_read(0); +} + +sub enable_read { + my Danga::Client $self = shift; + $self->{disable_read}--; + if ($self->{disable_read} <= 0) { + $self->{disable_read} = 0; + $self->watch_read(1); + } +} + +sub process_line { + my Danga::Client $self = shift; + return ''; +} + +sub close { + my Danga::Client $self = shift; + $self->{closing} = 1; + print "closing @_\n" if $::DEBUG; + $self->SUPER::close(@_); +} + +sub event_err { my Danga::Client $self = shift; $self->close("Error") } +sub event_hup { my Danga::Client $self = shift; $self->close("Disconnect (HUP)") } + +1; diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm new file mode 100644 index 0000000..dc8128a --- /dev/null +++ b/lib/Danga/DNS.pm @@ -0,0 +1,170 @@ +# $Id: DNS.pm,v 1.12 2005/02/14 22:06:08 msergeant Exp $ + +package Danga::DNS; + +# This is the query class - it is really just an encapsulation of the +# hosts you want to query, plus the callback. All the hard work is done +# in Danga::DNS::Resolver. + +use fields qw(client hosts num_hosts callback results start); +use strict; + +use Danga::DNS::Resolver; + +my $resolver; + +sub trace { + my $level = shift; + print STDERR ("[$$] dns lookup: @_") if $::DEBUG >= $level; +} + +sub new { + my Danga::DNS $self = shift; + my %options = @_; + + $resolver ||= Danga::DNS::Resolver->new(); + + my $client = $options{client}; + $client->disable_read if $client; + + $self = fields::new($self) unless ref $self; + + $self->{hosts} = $options{hosts} ? $options{hosts} : [ $options{host} ]; + $self->{num_hosts} = scalar(@{$self->{hosts}}) || "No hosts supplied"; + $self->{client} = $client; + $self->{callback} = $options{callback} || die "No callback given"; + $self->{results} = {}; + $self->{start} = time; + + if ($options{type}) { + if ($options{type} eq 'TXT') { + if (!$resolver->query_txt($self, @{$self->{hosts}})) { + $client->enable_read() if $client; + return; + } + } + elsif ($options{type} eq 'A') { + if (!$resolver->query($self, @{$self->{hosts}})) { + $client->enable_read() if $client; + return; + } + } + elsif ($options{type} eq 'PTR') { + if (!$resolver->query($self, @{$self->{hosts}})) { + $client->enable_read() if $client; + return; + } + } + elsif ($options{type} eq 'MX') { + if (!$resolver->query_mx($self, @{$self->{hosts}})) { + $client->enable_read() if $client; + return; + } + } + else { + die "Unsupported DNS query type: $options{type}"; + } + } + else { + if (!$resolver->query($self, @{$self->{hosts}})) { + $client->enable_read() if $client; + return; + } + } + + return $self; +} + +sub run_callback { + my Danga::DNS $self = shift; + my ($result, $query) = @_; + $self->{results}{$query} = $result; + trace(2, "got $query => $result\n"); + eval { + $self->{callback}->($result, $query); + }; + if ($@) { + warn($@); + } +} + +sub DESTROY { + my Danga::DNS $self = shift; + my $now = time; + foreach my $host (@{$self->{hosts}}) { + if (!exists($self->{results}{$host})) { + print STDERR "DNS timeout (presumably) looking for $host after " . ($now - $self->{start}) . " secs\n"; + $self->{callback}->("NXDOMAIN", $host); + } + } + $self->{client}->enable_read if $self->{client}; +} + +1; + +=head1 NAME + +Danga::DNS - a DNS lookup class for the Danga::Socket framework + +=head1 SYNOPSIS + + Danga::DNS->new(%options); + +=head1 DESCRIPTION + +This module performs asynchronous DNS lookups, making use of a single UDP +socket (unlike Net::DNS's bgsend/bgread combination), and blocking reading on +a client until the response comes back (this is useful for e.g. SMTP rDNS +lookups where you want the answer before you see the next SMTP command). + +Currently this module will only perform A or PTR lookups. A rDNS (PTR) lookup +will be performed if the host matches the regexp: C. + +The lookups time out after 15 seconds. + +=head1 API + +=head2 C<< Danga::DNS->new( %options ) >> + +Create a new DNS query. You do not need to store the resulting object as this +class is all done with callbacks. + +Example: + + Danga::DNS->new( + callback => sub { print "Got result: $_[0]\n" }, + host => 'google.com', + ); + +=over 4 + +=item B<[required]> C + +The callback to call when results come in. This should be a reference to a +subroutine. The callback receives two parameters - the result of the DNS lookup +and the host that was looked up. + +=item C + +A host name to lookup. Note that if the hostname is a dotted quad of numbers then +a reverse DNS (PTR) lookup is performend. + +=item C + +An array-ref list of hosts to lookup. + +B One of either C or C is B. + +=item C + +It is possible to specify a C object (or subclass) which you wish +to disable for reading until your DNS result returns. + +=item C + +You can specify one of: I<"A">, I<"PTR"> or I<"TXT"> here. Other types may be +supported in the future. + +=back + +=cut diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm new file mode 100644 index 0000000..48526a7 --- /dev/null +++ b/lib/Danga/DNS/Resolver.pm @@ -0,0 +1,307 @@ +# $Id: Resolver.pm,v 1.3 2005/02/14 22:06:08 msergeant Exp $ + +package Danga::DNS::Resolver; +use base qw(Danga::Socket); + +use fields qw(res dst id_to_asker id_to_query timeout cache cache_timeout); + +use Net::DNS; +use Socket; +use strict; + +our $last_cleanup = 0; + +sub trace { + my $level = shift; + print ("$::DEBUG/$level [$$] dns lookup: @_") if $::DEBUG >= $level; +} + +sub new { + my Danga::DNS::Resolver $self = shift; + + $self = fields::new($self) unless ref $self; + + my $res = Net::DNS::Resolver->new; + + my $sock = IO::Socket::INET->new( + Proto => 'udp', + LocalAddr => $res->{'srcaddr'}, + LocalPort => ($res->{'srcport'} || undef), + ) || die "Cannot create socket: $!"; + IO::Handle::blocking($sock, 0); + + trace(2, "Using nameserver $res->{nameservers}->[0]:$res->{port}\n"); + my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton($res->{'nameservers'}->[0])); + #my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton('127.0.0.1')); + #my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton('10.2.1.20')); + + $self->{res} = $res; + $self->{dst} = $dst_sockaddr; + $self->{id_to_asker} = {}; + $self->{id_to_query} = {}; + $self->{timeout} = {}; + $self->{cache} = {}; + $self->{cache_timeout} = {}; + + $self->SUPER::new($sock); + + $self->watch_read(1); + + $self->AddTimer(5, sub { $self->_do_cleanup }); + + return $self; +} + +sub pending { + my Danga::DNS::Resolver $self = shift; + + return keys(%{$self->{id_to_asker}}); +} + +sub _query { + my Danga::DNS::Resolver $self = shift; + my ($asker, $host, $type, $now) = @_; + + if ($ENV{NODNS}) { + $asker->run_callback("NXDNS", $host); + return 1; + } + if (exists $self->{cache}{$type}{$host}) { + # print "CACHE HIT!\n"; + $asker->run_callback($self->{cache}{$type}{$host}, $host); + return 1; + } + + my $packet = $self->{res}->make_query_packet($host, $type); + my $packet_data = $packet->data; + + my $h = $packet->header; + my $id = $h->id; + + if (!$self->sock->send($packet_data, 0, $self->{dst})) { + return; + } + + trace(2, "Query: $host ($id)\n"); + + $self->{id_to_asker}->{$id} = $asker; + $self->{id_to_query}->{$id} = $host; + $self->{timeout}->{$id} = $now; + + return 1; +} + +sub query_txt { + my Danga::DNS::Resolver $self = shift; + my ($asker, @hosts) = @_; + + my $now = time(); + + trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve TXT: @hosts\n"); + + foreach my $host (@hosts) { + $self->_query($asker, $host, 'TXT', $now) || return; + } + + #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + + return 1; +} + +sub query_mx { + my Danga::DNS::Resolver $self = shift; + my ($asker, @hosts) = @_; + + my $now = time(); + + trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve MX: @hosts\n"); + + foreach my $host (@hosts) { + $self->_query($asker, $host, 'MX', $now) || return; + } + + #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + + return 1; +} + +sub query { + my Danga::DNS::Resolver $self = shift; + my ($asker, @hosts) = @_; + + my $now = time(); + + trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve A/PTR: @hosts\n"); + + foreach my $host (@hosts) { + $self->_query($asker, $host, 'A', $now) || return; + } + + #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + + return 1; +} + +sub _do_cleanup { + my Danga::DNS::Resolver $self = shift; + my $now = time; + + $self->AddTimer(5, sub { $self->_do_cleanup }); + + my $idle = $self->max_idle_time; + + my @to_delete; + while (my ($id, $t) = each(%{$self->{timeout}})) { + if ($t < ($now - $idle)) { + push @to_delete, $id; + } + } + + foreach my $id (@to_delete) { + delete $self->{timeout}{$id}; + my $asker = delete $self->{id_to_asker}{$id}; + my $query = delete $self->{id_to_query}{$id}; + $asker->run_callback("NXDOMAIN", $query); + } + + foreach my $type ('A', 'TXT') { + @to_delete = (); + + while (my ($query, $t) = each(%{$self->{cache_timeout}{$type}})) { + if ($t < $now) { + push @to_delete, $query; + } + } + + foreach my $q (@to_delete) { + delete $self->{cache_timeout}{$type}{$q}; + delete $self->{cache}{$type}{$q}; + } + } +} + +# seconds max timeout! +sub max_idle_time { 30 } + +# Danga::DNS +sub event_err { shift->close("dns socket error") } +sub event_hup { shift->close("dns socket error") } + +sub event_read { + my Danga::DNS::Resolver $self = shift; + + while (my $packet = $self->{res}->bgread($self->sock)) { + my $err = $self->{res}->errorstring; + my $answers = 0; + my $header = $packet->header; + my $id = $header->id; + + my $asker = delete $self->{id_to_asker}->{$id}; + my $query = delete $self->{id_to_query}->{$id}; + delete $self->{timeout}{$id}; + + #print "-Pending queries: " . keys(%{$self->{id_to_asker}}) . + # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; + if (!$asker) { + trace(1, "No asker for id: $id\n"); + return; + } + + my $now = time(); + my @questions = $packet->question; + #print STDERR "response to ", $questions[0]->string, "\n"; + foreach my $rr ($packet->answer) { + # my $q = shift @questions; + if ($rr->type eq "PTR") { + my $rdns = $rr->ptrdname; + if ($query) { + # NB: Cached as an "A" lookup as there's no overlap and they + # go through the same query() function above + $self->{cache}{A}{$query} = $rdns; + $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + } + $asker->run_callback($rdns, $query); + } + elsif ($rr->type eq "A") { + my $ip = $rr->address; + if ($query) { + $self->{cache}{A}{$query} = $ip; + $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + } + $asker->run_callback($ip, $query); + } + elsif ($rr->type eq "TXT") { + my $txt = $rr->txtdata; + if ($query) { + $self->{cache}{TXT}{$query} = $txt; + $self->{cache_timeout}{TXT}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + } + $asker->run_callback($txt, $query); + } + else { + # came back, but not a PTR or A record + $asker->run_callback("unknown", $query); + } + $answers++; + } + if (!$answers) { + if ($err eq "NXDOMAIN") { + # trace("found => NXDOMAIN\n"); + $asker->run_callback("NXDOMAIN", $query); + } + elsif ($err eq "SERVFAIL") { + # try again??? + print "SERVFAIL looking for $query (Pending: " . keys(%{$self->{id_to_asker}}) . ")\n"; + #$self->query($asker, $query); + $asker->run_callback($err, $query); + #$self->{id_to_asker}->{$id} = $asker; + #$self->{id_to_query}->{$id} = $query; + #$self->{timeout}{$id} = time(); + + } + elsif ($err eq "NOERROR") { + $asker->run_callback($err, $query); + } + elsif($err) { + print("error: $err\n"); + $asker->run_callback($err, $query); + } + else { + # trace("no answers\n"); + $asker->run_callback("NXDOMAIN", $query); + } + } + } +} + +use Carp qw(confess); + +sub close { + my Danga::DNS::Resolver $self = shift; + + $self->SUPER::close(shift); + # confess "Danga::DNS::Resolver socket should never be closed!"; +} + +1; + +=head1 NAME + +Danga::DNS::Resolver - an asynchronous DNS resolver class + +=head1 SYNOPSIS + + my $res = Danga::DNS::Resolver->new(); + + $res->query($obj, @hosts); # $obj implements $obj->run_callback() + +=head1 DESCRIPTION + +This is a low level DNS resolver class that works within the Danga::Socket +asynchronous I/O framework. Do not attempt to use this class standalone - use +the C class instead. + +=cut diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm new file mode 100644 index 0000000..e3663c2 --- /dev/null +++ b/lib/Danga/Socket.pm @@ -0,0 +1,899 @@ +########################################################################### + +=head1 NAME + +Danga::Socket - Event-driven async IO class + +=head1 SYNOPSIS + + use base ('Danga::Socket'); + +=head1 DESCRIPTION + +This is an abstract base class which provides the basic framework for +event-driven asynchronous IO. + +=cut + +########################################################################### + +package Danga::Socket; +use strict; + +use vars qw{$VERSION}; +$VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use fields qw(sock fd write_buf write_buf_offset write_buf_size + read_push_back post_loop_callback + peer_ip + closed event_watch debug_level); + +use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN + EPIPE EAGAIN EBADF ECONNRESET); + +use Socket qw(IPPROTO_TCP); +use Carp qw{croak confess}; + +use constant TCP_CORK => 3; # FIXME: not hard-coded (Linux-specific too) + +use constant DebugLevel => 0; + +# for epoll definitions: +our $HAVE_SYSCALL_PH = eval { require 'syscall.ph'; 1 } || eval { require 'sys/syscall.ph'; 1 }; +our $HAVE_KQUEUE = eval { require IO::KQueue; 1 }; + +# Explicitly define the poll constants, as either one set or the other won't be +# loaded. They're also badly implemented in IO::Epoll: +# The IO::Epoll module is buggy in that it doesn't export constants efficiently +# (at least as of 0.01), so doing constants ourselves saves 13% of the user CPU +# time +use constant EPOLLIN => 1; +use constant EPOLLOUT => 4; +use constant EPOLLERR => 8; +use constant EPOLLHUP => 16; +use constant EPOLL_CTL_ADD => 1; +use constant EPOLL_CTL_DEL => 2; +use constant EPOLL_CTL_MOD => 3; + +use constant POLLIN => 1; +use constant POLLOUT => 4; +use constant POLLERR => 8; +use constant POLLHUP => 16; +use constant POLLNVAL => 32; + +# keep track of active clients +our ( + $HaveEpoll, # Flag -- is epoll available? initially undefined. + $HaveKQueue, + %DescriptorMap, # fd (num) -> Danga::Socket object + %PushBackSet, # fd (num) -> Danga::Socket (fds with pushed back read data) + $Epoll, # Global epoll fd (for epoll mode only) + $KQueue, # Global kqueue fd (for kqueue mode only) + @ToClose, # sockets to close when event loop is done + %OtherFds, # A hash of "other" (non-Danga::Socket) file + # descriptors for the event loop to track. + $PostLoopCallback, # subref to call at the end of each loop, if defined + %PLCMap, # fd (num) -> PostLoopCallback + @Timers, # timers + ); + +%OtherFds = (); + +##################################################################### +### C L A S S M E T H O D S +##################################################################### + +### (CLASS) METHOD: HaveEpoll() +### Returns a true value if this class will use IO::Epoll for async IO. +sub HaveEpoll { $HaveEpoll }; + +### (CLASS) METHOD: WatchedSockets() +### Returns the number of file descriptors which are registered with the global +### poll object. +sub WatchedSockets { + return scalar keys %DescriptorMap; +} +*watched_sockets = *WatchedSockets; + + +### (CLASS) METHOD: ToClose() +### Return the list of sockets that are awaiting close() at the end of the +### current event loop. +sub ToClose { return @ToClose; } + + +### (CLASS) METHOD: OtherFds( [%fdmap] ) +### Get/set the hash of file descriptors that need processing in parallel with +### the registered Danga::Socket objects. +sub OtherFds { + my $class = shift; + if ( @_ ) { %OtherFds = @_ } + return wantarray ? %OtherFds : \%OtherFds; +} + +sub AddTimer { + my $class = shift; + my ($secs, $coderef) = @_; + my $timeout = time + $secs; + + if (!@Timers || ($timeout >= $Timers[-1][0])) { + push @Timers, [$timeout, $coderef]; + return; + } + + # Now where do we insert... + for (my $i = 0; $i < @Timers; $i++) { + if ($Timers[$i][0] > $timeout) { + splice(@Timers, $i, 0, [$timeout, $coderef]); + return; + } + } + + die "Shouldn't get here spank matt."; +} + +### (CLASS) METHOD: DescriptorMap() +### Get the hash of Danga::Socket objects keyed by the file descriptor they are +### wrapping. +sub DescriptorMap { + return wantarray ? %DescriptorMap : \%DescriptorMap; +} +*descriptor_map = *DescriptorMap; +*get_sock_ref = *DescriptorMap; + +sub init_poller +{ + return if defined $HaveEpoll || $HaveKQueue; + + if ($HAVE_KQUEUE) { + $KQueue = IO::KQueue->new(); + $HaveKQueue = $KQueue >= 0; + if ($HaveKQueue) { + *EventLoop = *KQueueEventLoop; + } + } + else { + $Epoll = eval { epoll_create(1024); }; + $HaveEpoll = $Epoll >= 0; + if ($HaveEpoll) { + *EventLoop = *EpollEventLoop; + } + } + + if (!$HaveEpoll && !$HaveKQueue) { + require IO::Poll; + *EventLoop = *PollEventLoop; + } +} + +### FUNCTION: EventLoop() +### Start processing IO events. +sub EventLoop { + my $class = shift; + + init_poller(); + + if ($HaveEpoll) { + EpollEventLoop($class); + } else { + PollEventLoop($class); + } +} + +### The kqueue-based event loop. Gets installed as EventLoop if IO::KQueue works +### okay. +sub KQueueEventLoop { + my $class = shift; + + foreach my $fd (keys %OtherFds) { + $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), IO::KQueue::EV_ADD()); + } + + while (1) { + my $now = time; + # Run expired timers + while (@Timers && $Timers[0][0] <= $now) { + my $to_run = shift(@Timers); + $to_run->[1]->($now); + } + + # Get next timeout + my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; + # print STDERR "kevent($timeout)\n"; + my @ret = $KQueue->kevent($timeout * 1000); + + foreach my $kev (@ret) { + my ($fd, $filter, $flags, $fflags) = @$kev; + + my Danga::Socket $pob = $DescriptorMap{$fd}; + + # prioritise OtherFds first - likely to be accept() socks (?) + if (!$pob) { + if (my $code = $OtherFds{$fd}) { + $code->($filter); + } + else { + print STDERR "kevent() returned fd $fd for which we have no mapping. removing.\n"; + POSIX::close($fd); # close deletes the kevent entry + } + next; + } + + DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", + $fd, ref($pob), $flags, time); + + $pob->event_read if $filter == IO::KQueue::EVFILT_READ() && !$pob->{closed}; + $pob->event_write if $filter == IO::KQueue::EVFILT_WRITE() && !$pob->{closed}; + if ($flags == IO::KQueue::EV_EOF() && !$pob->{closed}) { + if ($fflags) { + $pob->event_err; + } else { + $pob->event_hup; + } + } + } + + return unless PostEventLoop(); + } + + exit(0); +} + +### The epoll-based event loop. Gets installed as EventLoop if IO::Epoll loads +### okay. +sub EpollEventLoop { + my $class = shift; + + foreach my $fd ( keys %OtherFds ) { + epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, EPOLLIN); + } + + while (1) { + my $now = time; + # Run expired timers + while (@Timers && $Timers[0][0] <= $now) { + my $to_run = shift(@Timers); + $to_run->[1]->($now); + } + + # Get next timeout + my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; + + my @events; + my $i; + my $evcount = epoll_wait($Epoll, 1000, $timeout * 1000, \@events); + + EVENT: + for ($i=0; $i<$evcount; $i++) { + my $ev = $events[$i]; + + # it's possible epoll_wait returned many events, including some at the end + # that ones in the front triggered unregister-interest actions. if we + # can't find the %sock entry, it's because we're no longer interested + # in that event. + my Danga::Socket $pob = $DescriptorMap{$ev->[0]}; + my $code; + my $state = $ev->[1]; + + # if we didn't find a Perlbal::Socket subclass for that fd, try other + # pseudo-registered (above) fds. + if (! $pob) { + if (my $code = $OtherFds{$ev->[0]}) { + $code->($state); + } + else { + my $fd = $ev->[0]; + print STDERR "epoll() returned fd $fd w/ state $state for which we have no mapping. removing.\n"; + POSIX::close($fd); + epoll_ctl($Epoll, EPOLL_CTL_DEL, $fd, 0); + } + next; + } + + DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", + $ev->[0], ref($pob), $ev->[1], time); + + $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; + $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; + $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; + $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; + } + + return unless PostEventLoop(); + } + exit 0; +} + +### The fallback IO::Poll-based event loop. Gets installed as EventLoop if +### IO::Epoll fails to load. +sub PollEventLoop { + my $class = shift; + + my Danga::Socket $pob; + + while (1) { + my $now = time; + # Run expired timers + while (@Timers && $Timers[0][0] <= $now) { + my $to_run = shift(@Timers); + $to_run->[1]->($now); + } + + # Get next timeout + my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; + + # the following sets up @poll as a series of ($poll,$event_mask) + # items, then uses IO::Poll::_poll, implemented in XS, which + # modifies the array in place with the even elements being + # replaced with the event masks that occured. + my @poll; + foreach my $fd ( keys %OtherFds ) { + push @poll, $fd, POLLIN; + } + foreach my $fd ( keys %DescriptorMap ) { + my Danga::Socket $sock = $DescriptorMap{$fd}; + push @poll, $fd, $sock->{event_watch}; + } + return 0 unless @poll; + + # print STDERR "Poll for $timeout secs\n"; + my $count = IO::Poll::_poll($timeout * 1000, @poll); + + # Fetch handles with read events + while (@poll) { + my ($fd, $state) = splice(@poll, 0, 2); + next unless $state; + + $pob = $DescriptorMap{$fd}; + + if ( !$pob && (my $code = $OtherFds{$fd}) ) { + $code->($state); + next; + } + + $pob->event_read if $state & POLLIN && ! $pob->{closed}; + $pob->event_write if $state & POLLOUT && ! $pob->{closed}; + $pob->event_err if $state & POLLERR && ! $pob->{closed}; + $pob->event_hup if $state & POLLHUP && ! $pob->{closed}; + } + + return unless PostEventLoop(); + } + + exit 0; +} + +## PostEventLoop is called at the end of the event loop to process things +# like close() calls. +sub PostEventLoop { + # fire read events for objects with pushed-back read data + my $loop = 1; + while ($loop) { + $loop = 0; + foreach my $fd (keys %PushBackSet) { + my Danga::Socket $pob = $PushBackSet{$fd}; + next unless (! $pob->{closed} && + $pob->{event_watch} & POLLIN); + $loop = 1; + $pob->event_read; + } + } + + # now we can close sockets that wanted to close during our event processing. + # (we didn't want to close them during the loop, as we didn't want fd numbers + # being reused and confused during the event loop) + foreach my $f (@ToClose) { + close($f); + } + @ToClose = (); + + # now we're at the very end, call per-connection callbacks if defined + my $ret = 1; # use $ret so's to not starve some FDs; return 0 if any PLCs return 0 + for my $plc (values %PLCMap) { + $ret &&= $plc->(\%DescriptorMap, \%OtherFds); + } + + # now we're at the very end, call global callback if defined + if (defined $PostLoopCallback) { + $ret &&= $PostLoopCallback->(\%DescriptorMap, \%OtherFds); + } + return $ret; +} + + +### (CLASS) METHOD: DebugMsg( $format, @args ) +### Print the debugging message specified by the C-style I and +### I +sub DebugMsg { + my ( $class, $fmt, @args ) = @_; + chomp $fmt; + printf STDERR ">>> $fmt\n", @args; +} + + +### METHOD: new( $socket ) +### Create a new Danga::Socket object for the given I which will react +### to events on it during the C. +sub new { + my Danga::Socket $self = shift; + $self = fields::new($self) unless ref $self; + + my $sock = shift; + + $self->{sock} = $sock; + my $fd = fileno($sock); + $self->{fd} = $fd; + $self->{write_buf} = []; + $self->{write_buf_offset} = 0; + $self->{write_buf_size} = 0; + $self->{closed} = 0; + $self->{read_push_back} = []; + $self->{post_loop_callback} = undef; + + $self->{event_watch} = POLLERR|POLLHUP|POLLNVAL; + + init_poller(); + + if ($HaveEpoll) { + epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, $self->{event_watch}) + and die "couldn't add epoll watch for $fd\n"; + } + elsif ($HaveKQueue) { + # Add them to the queue but disabled for now + $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), + IO::KQueue::EV_ADD() | IO::KQueue::EV_DISABLE()); + $KQueue->EV_SET($fd, IO::KQueue::EVFILT_WRITE(), + IO::KQueue::EV_ADD() | IO::KQueue::EV_DISABLE()); + } + + $DescriptorMap{$fd} = $self; + return $self; +} + + + +##################################################################### +### I N S T A N C E M E T H O D S +##################################################################### + +### METHOD: tcp_cork( $boolean ) +### Turn TCP_CORK on or off depending on the value of I. +sub tcp_cork { + my Danga::Socket $self = shift; + my $val = shift; + + # FIXME: Linux-specific. + setsockopt($self->{sock}, IPPROTO_TCP, TCP_CORK, + pack("l", $val ? 1 : 0)) || die "setsockopt: $!"; +} + +### METHOD: close( [$reason] ) +### Close the socket. The I argument will be used in debugging messages. +sub close { + my Danga::Socket $self = shift; + my $reason = shift || ""; + + my $fd = $self->{fd}; + my $sock = $self->{sock}; + $self->{closed} = 1; + + # we need to flush our write buffer, as there may + # be self-referential closures (sub { $client->close }) + # preventing the object from being destroyed + $self->{write_buf} = []; + + if (DebugLevel) { + my ($pkg, $filename, $line) = caller; + print STDERR "Closing \#$fd due to $pkg/$filename/$line ($reason)\n"; + } + + if ($HaveEpoll) { + if (epoll_ctl($Epoll, EPOLL_CTL_DEL, $fd, $self->{event_watch}) == 0) { + DebugLevel >= 1 && $self->debugmsg("Client %d disconnected.\n", $fd); + } else { + DebugLevel >= 1 && $self->debugmsg("poll->remove failed on fd %d\n", $fd); + } + } + + delete $PLCMap{$fd}; + delete $DescriptorMap{$fd}; + delete $PushBackSet{$fd}; + + # defer closing the actual socket until the event loop is done + # processing this round of events. (otherwise we might reuse fds) + push @ToClose, $sock; + + return 0; +} + + + +### METHOD: sock() +### Returns the underlying IO::Handle for the object. +sub sock { + my Danga::Socket $self = shift; + return $self->{sock}; +} + + +### METHOD: write( $data ) +### Write the specified data to the underlying handle. I may be scalar, +### scalar ref, code ref (to run when there), or undef just to kick-start. +### Returns 1 if writes all went through, or 0 if there are writes in queue. If +### it returns 1, caller should stop waiting for 'writable' events) +sub write { + my Danga::Socket $self; + my $data; + ($self, $data) = @_; + + # nobody should be writing to closed sockets, but caller code can + # do two writes within an event, have the first fail and + # disconnect the other side (whose destructor then closes the + # calling object, but it's still in a method), and then the + # now-dead object does its second write. that is this case. we + # just lie and say it worked. it'll be dead soon and won't be + # hurt by this lie. + return 1 if $self->{closed}; + + my $bref; + + # just queue data if there's already a wait + my $need_queue; + + if (defined $data) { + $bref = ref $data ? $data : \$data; + if ($self->{write_buf_size}) { + push @{$self->{write_buf}}, $bref; + $self->{write_buf_size} += ref $bref eq "SCALAR" ? length($$bref) : 1; + return 0; + } + + # this flag says we're bypassing the queue system, knowing we're the + # only outstanding write, and hoping we don't ever need to use it. + # if so later, though, we'll need to queue + $need_queue = 1; + } + + WRITE: + while (1) { + return 1 unless $bref ||= $self->{write_buf}[0]; + + my $len; + eval { + $len = length($$bref); # this will die if $bref is a code ref, caught below + }; + if ($@) { + if (ref $bref eq "CODE") { + unless ($need_queue) { + $self->{write_buf_size}--; # code refs are worth 1 + shift @{$self->{write_buf}}; + } + $bref->(); + undef $bref; + next WRITE; + } + die "Write error: $@ <$bref>"; + } + + my $to_write = $len - $self->{write_buf_offset}; + my $written = syswrite($self->{sock}, $$bref, $to_write, $self->{write_buf_offset}); + + if (! defined $written) { + if ($! == EPIPE) { + return $self->close("EPIPE"); + } elsif ($! == EAGAIN) { + # since connection has stuff to write, it should now be + # interested in pending writes: + if ($need_queue) { + push @{$self->{write_buf}}, $bref; + $self->{write_buf_size} += $len; + } + $self->watch_write(1); + return 0; + } elsif ($! == ECONNRESET) { + return $self->close("ECONNRESET"); + } + + DebugLevel >= 1 && $self->debugmsg("Closing connection ($self) due to write error: $!\n"); + + return $self->close("write_error"); + } elsif ($written != $to_write) { + DebugLevel >= 2 && $self->debugmsg("Wrote PARTIAL %d bytes to %d", + $written, $self->{fd}); + if ($need_queue) { + push @{$self->{write_buf}}, $bref; + $self->{write_buf_size} += $len; + } + # since connection has stuff to write, it should now be + # interested in pending writes: + $self->{write_buf_offset} += $written; + $self->{write_buf_size} -= $written; + $self->watch_write(1); + return 0; + } elsif ($written == $to_write) { + DebugLevel >= 2 && $self->debugmsg("Wrote ALL %d bytes to %d (nq=%d)", + $written, $self->{fd}, $need_queue); + $self->{write_buf_offset} = 0; + + # this was our only write, so we can return immediately + # since we avoided incrementing the buffer size or + # putting it in the buffer. we also know there + # can't be anything else to write. + return 1 if $need_queue; + + $self->{write_buf_size} -= $written; + shift @{$self->{write_buf}}; + undef $bref; + next WRITE; + } + } +} + +### METHOD: push_back_read( $buf ) +### Push back I (a scalar or scalarref) into the read stream +sub push_back_read { + my Danga::Socket $self = shift; + my $buf = shift; + push @{$self->{read_push_back}}, ref $buf ? $buf : \$buf; + $PushBackSet{$self->{fd}} = $self; +} + +### METHOD: shift_back_read( $buf ) +### Shift back I (a scalar or scalarref) into the read stream +### Use this instead of push_back_read() when you need to unread +### something you just read. +sub shift_back_read { + my Danga::Socket $self = shift; + my $buf = shift; + unshift @{$self->{read_push_back}}, ref $buf ? $buf : \$buf; + $PushBackSet{$self->{fd}} = $self; +} + +### METHOD: read( $bytecount ) +### Read at most I bytes from the underlying handle; returns scalar +### ref on read, or undef on connection closed. +sub read { + my Danga::Socket $self = shift; + my $bytes = shift; + my $buf; + my $sock = $self->{sock}; + + if (@{$self->{read_push_back}}) { + $buf = shift @{$self->{read_push_back}}; + my $len = length($$buf); + if ($len <= $buf) { + unless (@{$self->{read_push_back}}) { + delete $PushBackSet{$self->{fd}}; + } + return $buf; + } else { + # if the pushed back read is too big, we have to split it + my $overflow = substr($$buf, $bytes); + $buf = substr($$buf, 0, $bytes); + unshift @{$self->{read_push_back}}, \$overflow, + return \$buf; + } + } + + my $res = sysread($sock, $buf, $bytes, 0); + DebugLevel >= 2 && $self->debugmsg("sysread = %d; \$! = %d", $res, $!); + + if (! $res && $! != EWOULDBLOCK) { + # catches 0=conn closed or undef=error + DebugLevel >= 2 && $self->debugmsg("Fd \#%d read hit the end of the road.", $self->{fd}); + return undef; + } + + return \$buf; +} + + +### (VIRTUAL) METHOD: event_read() +### Readable event handler. Concrete deriviatives of Danga::Socket should +### provide an implementation of this. The default implementation will die if +### called. +sub event_read { die "Base class event_read called for $_[0]\n"; } + + +### (VIRTUAL) METHOD: event_err() +### Error event handler. Concrete deriviatives of Danga::Socket should +### provide an implementation of this. The default implementation will die if +### called. +sub event_err { die "Base class event_err called for $_[0]\n"; } + + +### (VIRTUAL) METHOD: event_hup() +### 'Hangup' event handler. Concrete deriviatives of Danga::Socket should +### provide an implementation of this. The default implementation will die if +### called. +sub event_hup { die "Base class event_hup called for $_[0]\n"; } + + +### METHOD: event_write() +### Writable event handler. Concrete deriviatives of Danga::Socket may wish to +### provide an implementation of this. The default implementation calls +### C with an C. +sub event_write { + my $self = shift; + $self->write(undef); +} + + +### METHOD: watch_read( $boolean ) +### Turn 'readable' event notification on or off. +sub watch_read { + my Danga::Socket $self = shift; + return if $self->{closed}; + + my $val = shift; + my $event = $self->{event_watch}; + + $event &= ~POLLIN if ! $val; + $event |= POLLIN if $val; + + # If it changed, set it + if ($event != $self->{event_watch}) { + if ($HaveKQueue) { + $KQueue->EV_SET($self->{fd}, IO::KQueue::EVFILT_READ(), + $val ? IO::KQueue::EV_ENABLE() : IO::KQueue::EV_DISABLE()); + } + elsif ($HaveEpoll) { + epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) + and print STDERR "couldn't modify epoll settings for $self->{fd} " . + "($self) from $self->{event_watch} -> $event\n"; + } + $self->{event_watch} = $event; + } +} + +### METHOD: watch_read( $boolean ) +### Turn 'writable' event notification on or off. +sub watch_write { + my Danga::Socket $self = shift; + return if $self->{closed}; + + my $val = shift; + my $event = $self->{event_watch}; + + $event &= ~POLLOUT if ! $val; + $event |= POLLOUT if $val; + + # If it changed, set it + if ($event != $self->{event_watch}) { + if ($HaveKQueue) { + $KQueue->EV_SET($self->{fd}, IO::KQueue::EVFILT_WRITE(), + $val ? IO::KQueue::EV_ENABLE() : IO::KQueue::EV_DISABLE()); + } + elsif ($HaveEpoll) { + epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) + and print STDERR "couldn't modify epoll settings for $self->{fd} " . + "($self) from $self->{event_watch} -> $event\n"; + } + $self->{event_watch} = $event; + } +} + + +### METHOD: debugmsg( $format, @args ) +### Print the debugging message specified by the C-style I and +### I if the object's C is greater than or equal to the given +### I. +sub debugmsg { + my ( $self, $fmt, @args ) = @_; + confess "Not an object" unless ref $self; + + chomp $fmt; + printf STDERR ">>> $fmt\n", @args; +} + + +### METHOD: peer_ip_string() +### Returns the string describing the peer's IP +sub peer_ip_string { + my Danga::Socket $self = shift; + return $self->{peer_ip} if defined $self->{peer_ip}; + my $pn = getpeername($self->{sock}) or return undef; + my ($port, $iaddr) = Socket::sockaddr_in($pn); + my $r = Socket::inet_ntoa($iaddr); + $self->{peer_ip} = $r; + return $r; +} + +### METHOD: peer_addr_string() +### Returns the string describing the peer for the socket which underlies this +### object in form "ip:port" +sub peer_addr_string { + my Danga::Socket $self = shift; + my $pn = getpeername($self->{sock}) or return undef; + my ($port, $iaddr) = Socket::sockaddr_in($pn); + return Socket::inet_ntoa($iaddr) . ":$port"; +} + +### METHOD: as_string() +### Returns a string describing this socket. +sub as_string { + my Danga::Socket $self = shift; + my $ret = ref($self) . ": " . ($self->{closed} ? "closed" : "open"); + my $peer = $self->peer_addr_string; + if ($peer) { + $ret .= " to " . $self->peer_addr_string; + } + return $ret; +} + +### CLASS METHOD: SetPostLoopCallback +### Sets post loop callback function. Pass a subref and it will be +### called every time the event loop finishes. Return 1 from the sub +### to make the loop continue, else it will exit. The function will +### be passed two parameters: \%DescriptorMap, \%OtherFds. +sub SetPostLoopCallback { + my ($class, $ref) = @_; + if(ref $class) { + my Danga::Socket $self = $class; + if( defined $ref && ref $ref eq 'CODE' ) { + $PLCMap{$self->{fd}} = $ref; + } + else { + delete $PLCMap{$self->{fd}}; + } + } + else { + $PostLoopCallback = (defined $ref && ref $ref eq 'CODE') ? $ref : undef; + } +} + +sub DESTROY { + my Danga::Socket $self = shift; + $self->close() if !$self->{closed}; +} + +##################################################################### +### U T I L I T Y F U N C T I O N S +##################################################################### + +our $SYS_epoll_create = eval { &SYS_epoll_create } || 254; # linux-ix86 default + +# epoll_create wrapper +# ARGS: (size) +sub epoll_create { + my $epfd = eval { syscall($SYS_epoll_create, $_[0]) }; + return -1 if $@; + return $epfd; +} + +# epoll_ctl wrapper +# ARGS: (epfd, op, fd, events) +our $SYS_epoll_ctl = eval { &SYS_epoll_ctl } || 255; # linux-ix86 default +sub epoll_ctl { + syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLL", $_[3], $_[2])); +} + +# epoll_wait wrapper +# ARGS: (epfd, maxevents, timeout, arrayref) +# arrayref: values modified to be [$fd, $event] +our $epoll_wait_events; +our $epoll_wait_size = 0; +our $SYS_epoll_wait = eval { &SYS_epoll_wait } || 256; # linux-ix86 default +sub epoll_wait { + # resize our static buffer if requested size is bigger than we've ever done + if ($_[1] > $epoll_wait_size) { + $epoll_wait_size = $_[1]; + $epoll_wait_events = pack("LLL") x $epoll_wait_size; + } + my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0); + for ($_ = 0; $_ < $ct; $_++) { + @{$_[3]->[$_]}[1,0] = unpack("LL", substr($epoll_wait_events, 12*$_, 8)); + } + return $ct; +} + + + +1; + + +# Local Variables: +# mode: perl +# c-basic-indent: 4 +# indent-tabs-mode: nil +# End: diff --git a/lib/Danga/TimeoutSocket.pm b/lib/Danga/TimeoutSocket.pm new file mode 100644 index 0000000..d977570 --- /dev/null +++ b/lib/Danga/TimeoutSocket.pm @@ -0,0 +1,62 @@ +# $Id: TimeoutSocket.pm,v 1.2 2005/02/02 20:44:35 msergeant Exp $ + +package Danga::TimeoutSocket; + +use base 'Danga::Socket'; +use fields qw(alive_time create_time); + +our $last_cleanup = 0; + +Danga::Socket->AddTimer(15, \&_do_cleanup); + +sub new { + my Danga::TimeoutSocket $self = shift; + my $sock = shift; + $self = fields::new($self) unless ref($self); + $self->SUPER::new($sock); + + my $now = time; + $self->{alive_time} = $self->{create_time} = $now; + + return $self; +} + +# overload these in a subclass +sub max_idle_time { 0 } +sub max_connect_time { 0 } + +sub _do_cleanup { + my $now = time; + + Danga::Socket->AddTimer(15, \&_do_cleanup); + + my $sf = __PACKAGE__->get_sock_ref; + + my %max_age; # classname -> max age (0 means forever) + my %max_connect; # classname -> max connect time + my @to_close; + while (my $k = each %$sf) { + my Danga::TimeoutSocket $v = $sf->{$k}; + my $ref = ref $v; + next unless $v->isa('Danga::TimeoutSocket'); + unless (defined $max_age{$ref}) { + $max_age{$ref} = $ref->max_idle_time || 0; + $max_connect{$ref} = $ref->max_connect_time || 0; + } + if (my $t = $max_connect{$ref}) { + if ($v->{create_time} < $now - $t) { + push @to_close, $v; + next; + } + } + if (my $t = $max_age{$ref}) { + if ($v->{alive_time} < $now - $t) { + push @to_close, $v; + } + } + } + + $_->close("Timeout") foreach @to_close; +} + +1; From 54cff7af409925a0ecfea9b9e6342fe085e59905 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 12 Jul 2005 20:40:32 +0000 Subject: [PATCH 051/106] When setting OtherFds, always make it an addition to what's already set git-svn-id: https://svn.perl.org/qpsmtpd/trunk@498 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index e3663c2..2e1efd5 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -107,7 +107,7 @@ sub ToClose { return @ToClose; } ### the registered Danga::Socket objects. sub OtherFds { my $class = shift; - if ( @_ ) { %OtherFds = @_ } + if ( @_ ) { %OtherFds = (%OtherFds, @_) } return wantarray ? %OtherFds : \%OtherFds; } From e100e3d67a8cbd16d5dbee486bdaaee245b3f046 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 12 Jul 2005 21:59:30 +0000 Subject: [PATCH 052/106] Better fix for previous bug git-svn-id: https://svn.perl.org/qpsmtpd/trunk@499 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/queue/qmail-queue | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/plugins/queue/qmail-queue b/plugins/queue/qmail-queue index 9d592e6..b228c19 100644 --- a/plugins/queue/qmail-queue +++ b/plugins/queue/qmail-queue @@ -41,7 +41,8 @@ sub hook_queue { # these bits inspired by Peter Samuels "qmail-queue wrapper" pipe(MESSAGE_READER, MESSAGE_WRITER) or die("Could not create message pipe"); pipe(ENVELOPE_READER, ENVELOPE_WRITER) or die("Could not create envelope pipe"); - + + local $SIG{PIPE} = sub { die "SIGPIPE" }; my $child = fork(); not defined $child and die("Could not fork"); @@ -55,10 +56,6 @@ sub hook_queue { close MESSAGE_READER or die("close msg reader fault"); close ENVELOPE_READER or die("close envelope reader fault"); - # Note - technically there's a race here because if the exec() below - # fails and the writes to MESSAGE_WRITER block we get a deadlocked process. - # This check to see if(eof(PIPE)) will catch "most" of these problems. - die "Message pipe has been closed" if eof(MESSAGE_WRITER); $transaction->header->print(\*MESSAGE_WRITER); $transaction->body_resetpos; while (my $line = $transaction->body_getline) { @@ -68,7 +65,6 @@ sub hook_queue { my @rcpt = map { "T" . $_->address } $transaction->recipients; my $from = "F".($transaction->sender->address|| "" ); - die "Envelope pipe has been closed" if eof(ENVELOPE_WRITER); print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0" or return(DECLINED,"Could not print addresses to queue"); From 51f1f3292807f02c8694a881ed9cbec7e64fefac Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 13 Jul 2005 17:10:38 +0000 Subject: [PATCH 053/106] Fix for forkserver breakage git-svn-id: https://svn.perl.org/qpsmtpd/trunk@501 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 9a04930..a0f6cf5 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -71,12 +71,6 @@ $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; my %childstatus = (); sub REAPER { -# foreach my $chld (keys %childstatus) { -# if (defined(waitpid($chld, WNOHANG))) { -# ::log(LOGINFO,"cleaning up after $chld"); -# delete $childstatus{$chld}; -# } -# } while ( defined(my $chld = waitpid(-1, WNOHANG)) ){ last unless $chld > 0; ::log(LOGINFO,"cleaning up after $chld"); @@ -180,6 +174,9 @@ while (1) { # possible something condition... next; } + + # Make this client blocking while we figure out if we actually want to + # do something with it. IO::Handle::blocking($client, 1); my ($port, $iaddr) = sockaddr_in($hisaddr); if ($MAXCONNIP) { @@ -225,6 +222,8 @@ while (1) { $::LineMode = 1; + # Make this client non-blocking so it works with the Danga framework + IO::Handle::blocking($client, 0); my $qp = Qpsmtpd::PollServer->new($client); $qp->load_plugins; $qp->init_logger; From 2ca6e9d1929ca4be6f0937e20f3e41c33f9bcbac Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Thu, 14 Jul 2005 13:31:07 +0000 Subject: [PATCH 054/106] MERGE 503:505 FROM https://svn.perl.org/qpsmtpd/branches/0.31 Fix test failures due to hook renames Fix redefined warnings due to hook renames git-svn-id: https://svn.perl.org/qpsmtpd/trunk@507 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 4 +--- lib/Qpsmtpd/Plugin.pm | 4 ++-- t/plugin_tests/dnsbl | 4 ++-- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 2829cc7..0df81ff 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -238,7 +238,7 @@ sub _load_plugins { my $package = "Qpsmtpd::Plugin::$plugin_name"; # don't reload plugins if they are already loaded - unless ( defined &{"${package}::register"} ) { + unless ( defined &{"${package}::plugin_name"} ) { Qpsmtpd::Plugin->compile($plugin_name, $package, "$dir/$plugin", $self->{_test_mode}); $self->log(LOGDEBUG, "Loading $plugin_line") @@ -320,9 +320,7 @@ sub run_hook { } else { $self->varlog(LOGINFO, $hook, $code->{name}); - print STDERR "plugin $hook $code->{name} 1\n"; eval { (@r) = $code->{code}->($self, $self->transaction, @args); }; - print STDERR "plugin $hook $code->{name} 2\n"; $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and return; diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 15b05ff..5fd2d87 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -102,8 +102,8 @@ sub isa_plugin { $cleanParent =~ s/\W/_/g; my $newPackage = $currentPackage."::_isa_$cleanParent"; - - return if defined &{"${newPackage}::register"}; + # don't reload plugins if they are already loaded + return if defined &{"${newPackage}::plugin_name"}; $self->compile($self->plugin_name . "_isa_$cleanParent", $newPackage, diff --git a/t/plugin_tests/dnsbl b/t/plugin_tests/dnsbl index 6538de6..d36651d 100644 --- a/t/plugin_tests/dnsbl +++ b/t/plugin_tests/dnsbl @@ -11,7 +11,7 @@ sub test_local { my $connection = $self->qp->connection; $connection->remote_ip('127.0.0.2'); # standard dnsbl test value - $self->connect_handler($self->qp->transaction); + $self->hook_connect($self->qp->transaction); ok($self->qp->connection->notes('dnsbl_sockets')); } @@ -20,7 +20,7 @@ sub test_returnval { my $self = shift; my $address = Qpsmtpd::Address->parse(''); - my ($ret, $note) = $self->rcpt_handler($self->qp->transaction, + my ($ret, $note) = $self->hook_rcpt($self->qp->transaction, $address); is($ret, DENY, "Check we got a DENY"); print("# dnsbl result: $note\n"); From 30961641597d68e946d57ed7bd7214d2b1939b63 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 15 Jul 2005 10:35:23 +0000 Subject: [PATCH 055/106] Support smtpgreeting file from qmail/control git-svn-id: https://svn.perl.org/qpsmtpd/trunk@508 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 2a6172b..98c72ed 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -114,8 +114,9 @@ sub connect_respond { return $rc; } elsif ($rc != DONE) { - $self->respond(220, $self->config('me') ." ESMTP qpsmtpd " - . $self->version ." ready; send us your mail, but not your spam."); + $self->respond(220, $self->config('smtpgreeting') ." ESMTP" || + ($self->config('me') ." ESMTP qpsmtpd " . $self->version . + " ready; send us your mail, but not your spam.")); return DONE; } } @@ -382,7 +383,8 @@ sub rcpt_respond { sub help { my $self = shift; $self->respond(214, - "This is qpsmtpd " . $self->version, + "This is qpsmtpd " . + $self->config('smtpgreeting') ? '' : $self->version, "See http://smtpd.develooper.com/", 'To report bugs or send comments, mail to .'); } From e8a9828e4ec8a908e56708bfde7c37b865ce5873 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 15 Jul 2005 21:15:44 +0000 Subject: [PATCH 056/106] Notice /var/qmail/control dir (Joe Schaefer) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@510 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Apache/Qpsmtpd.pm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/Apache/Qpsmtpd.pm b/lib/Apache/Qpsmtpd.pm index 5161301..edb28c5 100644 --- a/lib/Apache/Qpsmtpd.pm +++ b/lib/Apache/Qpsmtpd.pm @@ -90,8 +90,10 @@ sub run { } sub config_dir { - my $self = shift; - return "$self->{qpdir}/config"; + my ($self, $config) = @_; + -e "$_/$config" and return $_ + for "$self->{qpdir}/config"; + return "/var/qmail/control"; } sub plugin_dir { From 43aef48532348b5b453421ecbc421a2c98839dfc Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 18 Jul 2005 00:36:49 +0000 Subject: [PATCH 057/106] Correctly handle the case where smtpgreeting exists (append ESMTP) as well as the case where it doesn't (display original Qpsmtpd greeting). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@511 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 98c72ed..4a84a30 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -114,9 +114,18 @@ sub connect_respond { return $rc; } elsif ($rc != DONE) { - $self->respond(220, $self->config('smtpgreeting') ." ESMTP" || - ($self->config('me') ." ESMTP qpsmtpd " . $self->version . - " ready; send us your mail, but not your spam.")); + my $greets = $self->config('smtpgreeting'); + if ( $greets ) { + $greets .= " ESMTP"; + } + else { + $greets = $self->config('me') + . " ESMTP qpsmtpd " + . $self->version + . " ready; send us your mail, but not your spam."; + } + + $self->respond(220, $greets); return DONE; } } From 5f3c2dfa2275622515014dade4bd3d31a01040bf Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 18 Jul 2005 11:07:18 +0000 Subject: [PATCH 058/106] Missed hook to data_post to add headers git-svn-id: https://svn.perl.org/qpsmtpd/trunk@512 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/sender_permitted_from | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/sender_permitted_from b/plugins/sender_permitted_from index 4297e6c..a0c678d 100644 --- a/plugins/sender_permitted_from +++ b/plugins/sender_permitted_from @@ -106,7 +106,7 @@ sub _uri_escape { return $str; } -sub hook_data { +sub hook_data_post { my ($self, $transaction) = @_; my $query = $transaction->notes('spfquery'); From f096f293c1ede171669312187439f50fcbce0cb5 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Mon, 18 Jul 2005 11:10:11 +0000 Subject: [PATCH 059/106] Missed hook to data_post to add headers git-svn-id: https://svn.perl.org/qpsmtpd/trunk@513 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/milter | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/milter b/plugins/milter index a577683..ff0e122 100644 --- a/plugins/milter +++ b/plugins/milter @@ -161,7 +161,7 @@ sub hook_rcpt { return DECLINED; } -sub hook_data { +sub hook_data_post { my ($self, $transaction) = @_; my $milter = $self->qp->connection->notes('milter'); From 7edb1fd93adb6c87f434c0517369e0c77cb7078a Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 18 Jul 2005 12:50:35 +0000 Subject: [PATCH 060/106] Fix "no pseudo hash" bug git-svn-id: https://svn.perl.org/qpsmtpd/trunk@515 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index df4eab4..c356dc5 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -59,7 +59,7 @@ sub register { 'defer-reject' => 0, @args, }; - if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) { + if ($qp->isa('Qpsmtpd::Apache')) { require APR::Const; APR::Const->import(qw(POLLIN SUCCESS)); $self->register_hook('connect', 'hook_connect_apr'); From 96ff5e10825904f2174b378e39a71f7c950e2a76 Mon Sep 17 00:00:00 2001 From: Robert Spier Date: Tue, 19 Jul 2005 03:24:42 +0000 Subject: [PATCH 061/106] r521@bear: rspier | 2005-07-19T03:24:18.553459Z MANIFEST update from steve peters git-svn-id: https://svn.perl.org/qpsmtpd/trunk@517 958fd67b-6ff1-0310-b445-bb7760255be9 --- MANIFEST | 2 -- 1 file changed, 2 deletions(-) diff --git a/MANIFEST b/MANIFEST index 15ddb19..ed0c5b2 100644 --- a/MANIFEST +++ b/MANIFEST @@ -17,7 +17,6 @@ lib/Qpsmtpd/Connection.pm lib/Qpsmtpd/Constants.pm lib/Qpsmtpd/Plugin.pm lib/Qpsmtpd/Postfix.pm -lib/Qpsmtpd/SelectServer.pm lib/Qpsmtpd/SMTP.pm lib/Qpsmtpd/TcpServer.pm lib/Qpsmtpd/Transaction.pm @@ -78,7 +77,6 @@ plugins/virus/sophie plugins/virus/uvscan qpsmtpd qpsmtpd-forkserver -qpsmtpd-server README README.logging README.plugins From 006f129c21e74974dacb6d4311028a6626a5842b Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 19 Jul 2005 15:37:14 +0000 Subject: [PATCH 062/106] Merge in a bunch of changes from Bradfitz's Danga::Socket 1.40-1.43 git-svn-id: https://svn.perl.org/qpsmtpd/trunk@519 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 109 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 95 insertions(+), 14 deletions(-) diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 2e1efd5..5ffac3d 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -33,6 +33,7 @@ use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN use Socket qw(IPPROTO_TCP); use Carp qw{croak confess}; +use POSIX (); use constant TCP_CORK => 3; # FIXME: not hard-coded (Linux-specific too) @@ -63,6 +64,8 @@ use constant POLLNVAL => 32; # keep track of active clients our ( + $DoneInit, # if we've done the one-time module init yet + $TryEpoll, # Whether epoll should be attempted to be used. $HaveEpoll, # Flag -- is epoll available? initially undefined. $HaveKQueue, %DescriptorMap, # fd (num) -> Danga::Socket object @@ -77,12 +80,24 @@ our ( @Timers, # timers ); -%OtherFds = (); +Reset(); ##################################################################### ### C L A S S M E T H O D S ##################################################################### +### (CLASS) METHOD: Reset() +### Reset all state +sub Reset { + %DescriptorMap = (); + %PushBackSet = (); + @ToClose = (); + %OtherFds = (); + $PostLoopCallback = undef; + %PLCMap = (); + @Timers = (); +} + ### (CLASS) METHOD: HaveEpoll() ### Returns a true value if this class will use IO::Epoll for async IO. sub HaveEpoll { $HaveEpoll }; @@ -143,7 +158,8 @@ sub DescriptorMap { sub init_poller { - return if defined $HaveEpoll || $HaveKQueue; + return if $DoneInit; + $DoneInit = 1; if ($HAVE_KQUEUE) { $KQueue = IO::KQueue->new(); @@ -152,9 +168,9 @@ sub init_poller *EventLoop = *KQueueEventLoop; } } - else { + elsif ($TryEpoll) { $Epoll = eval { epoll_create(1024); }; - $HaveEpoll = $Epoll >= 0; + $HaveEpoll = defined $Epoll && $Epoll >= 0; if ($HaveEpoll) { *EventLoop = *EpollEventLoop; } @@ -175,6 +191,8 @@ sub EventLoop { if ($HaveEpoll) { EpollEventLoop($class); + } elsif ($HaveKQueue) { + KQueueEventLoop($class); } else { PollEventLoop($class); } @@ -851,7 +869,54 @@ sub DESTROY { ### U T I L I T Y F U N C T I O N S ##################################################################### -our $SYS_epoll_create = eval { &SYS_epoll_create } || 254; # linux-ix86 default +our ($SYS_epoll_create, $SYS_epoll_ctl, $SYS_epoll_wait); + +if ($^O eq "linux") { + my ($sysname, $nodename, $release, $version, $machine) = POSIX::uname(); + + # whether the machine requires 64-bit numbers to be on 8-byte + # boundaries. + my $u64_mod_8 = 0; + + if ($machine =~ m/^i[3456]86$/) { + $SYS_epoll_create = 254; + $SYS_epoll_ctl = 255; + $SYS_epoll_wait = 256; + } elsif ($machine eq "x86_64") { + $SYS_epoll_create = 213; + $SYS_epoll_ctl = 233; + $SYS_epoll_wait = 232; + } elsif ($machine eq "ppc64") { + $SYS_epoll_create = 236; + $SYS_epoll_ctl = 237; + $SYS_epoll_wait = 238; + $u64_mod_8 = 1; + } elsif ($machine eq "ppc") { + $SYS_epoll_create = 236; + $SYS_epoll_ctl = 237; + $SYS_epoll_wait = 238; + $u64_mod_8 = 1; + } elsif ($machine eq "ia64") { + $SYS_epoll_create = 1243; + $SYS_epoll_ctl = 1244; + $SYS_epoll_wait = 1245; + $u64_mod_8 = 1; + } + + if ($u64_mod_8) { + *epoll_wait = \&epoll_wait_mod8; + *epoll_ctl = \&epoll_ctl_mod8; + } else { + *epoll_wait = \&epoll_wait_mod4; + *epoll_ctl = \&epoll_ctl_mod4; + } + + # if syscall numbers have been defined (and this module has been + # tested on) the arch above, then try to use it. try means see if + # the syscall is implemented. it may well be that this is Linux + # 2.4 and we don't even have it available. + $TryEpoll = 1 if $SYS_epoll_create; +} # epoll_create wrapper # ARGS: (size) @@ -862,23 +927,24 @@ sub epoll_create { } # epoll_ctl wrapper -# ARGS: (epfd, op, fd, events) -our $SYS_epoll_ctl = eval { &SYS_epoll_ctl } || 255; # linux-ix86 default -sub epoll_ctl { - syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLL", $_[3], $_[2])); +# ARGS: (epfd, op, fd, events_mask) +sub epoll_ctl_mod4 { + syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLL", $_[3], $_[2], 0)); +} +sub epoll_ctl_mod8 { + syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLLL", $_[3], 0, $_[2], 0)); } # epoll_wait wrapper -# ARGS: (epfd, maxevents, timeout, arrayref) +# ARGS: (epfd, maxevents, timeout (milliseconds), arrayref) # arrayref: values modified to be [$fd, $event] our $epoll_wait_events; our $epoll_wait_size = 0; -our $SYS_epoll_wait = eval { &SYS_epoll_wait } || 256; # linux-ix86 default -sub epoll_wait { +sub epoll_wait_mod4 { # resize our static buffer if requested size is bigger than we've ever done if ($_[1] > $epoll_wait_size) { $epoll_wait_size = $_[1]; - $epoll_wait_events = pack("LLL") x $epoll_wait_size; + $epoll_wait_events = "\0" x 12 x $epoll_wait_size; } my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0); for ($_ = 0; $_ < $ct; $_++) { @@ -887,7 +953,22 @@ sub epoll_wait { return $ct; } - +sub epoll_wait_mod8 { + # resize our static buffer if requested size is bigger than we've ever done + if ($_[1] > $epoll_wait_size) { + $epoll_wait_size = $_[1]; + $epoll_wait_events = "\0" x 16 x $epoll_wait_size; + } + my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0); + for ($_ = 0; $_ < $ct; $_++) { + # 16 byte epoll_event structs, with format: + # 4 byte mask [idx 1] + # 4 byte padding (we put it into idx 2, useless) + # 8 byte data (first 4 bytes are fd, into idx 0) + @{$_[3]->[$_]}[1,2,0] = unpack("LLL", substr($epoll_wait_events, 16*$_, 12)); + } + return $ct; +} 1; From 72a3056e666438e72be8cbb956a2d4ee25e97816 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 29 Jul 2005 18:02:07 +0000 Subject: [PATCH 063/106] Default capabilities to an empty arrayref Copy relay_client setting when cloning connection in tls git-svn-id: https://svn.perl.org/qpsmtpd/trunk@532 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Transaction.pm | 2 +- plugins/tls | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index a6dc3be..59f7453 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -13,7 +13,7 @@ sub start { my $proto = shift; my $class = ref($proto) || $proto; my %args = @_; - my $self = { _rcpt => [], started => time }; + my $self = { _notes => { capabilities => [] }, _rcpt => [], started => time }; bless ($self, $class); my $sz = $self->config('memory_threshold'); $sz = 10_000 unless defined($sz); diff --git a/plugins/tls b/plugins/tls index 7379350..df094f4 100644 --- a/plugins/tls +++ b/plugins/tls @@ -48,10 +48,8 @@ sub hook_ehlo { return DECLINED if $self->connection->notes('tls_enabled'); return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); my $cap = $transaction->notes('capabilities'); - $cap ||= []; push @$cap, 'STARTTLS'; $transaction->notes('tls_enabled', 1); - $transaction->notes('capabilities', $cap); return DECLINED; } @@ -92,7 +90,7 @@ sub hook_unrecognized_command { my $conn = $self->connection; # Create a new connection object with subset of information collected thus far my $newconn = Qpsmtpd::Connection->new(); - for (qw(local_ip local_port remote_ip remote_port remote_host remote_info)) { + for (qw(local_ip local_port remote_ip remote_port remote_host remote_info relay_client)) { $newconn->$_($conn->$_()); } $self->qp->connection($newconn); From 9d6faa39cb6f567f2aff3e80817130f1291f5634 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 29 Jul 2005 18:05:08 +0000 Subject: [PATCH 064/106] Migrate transaction(), reset_transaction() and connection() up to Qpsmtpd.pm Minor bug fix for auth capability git-svn-id: https://svn.perl.org/qpsmtpd/trunk@533 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 18 +++++++++++++++++- lib/Qpsmtpd/SMTP.pm | 29 +++-------------------------- 2 files changed, 20 insertions(+), 27 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 0df81ff..3af5ed6 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -4,6 +4,8 @@ use vars qw($VERSION $Logger $TraceLevel $Spool_dir); use Sys::Hostname; use Qpsmtpd::Constants; +use Qpsmtpd::Transaction; +use Qpsmtpd::Connection; $VERSION = "0.31-dev"; @@ -255,7 +257,21 @@ sub _load_plugins { } sub transaction { - return {}; # base class implements empty transaction + my $self = shift; + return $self->{_transaction} || $self->reset_transaction(); +} + +sub reset_transaction { + my $self = shift; + $self->run_hooks("reset_transaction") if $self->{_transaction}; + return $self->{_transaction} = Qpsmtpd::Transaction->new(); +} + + +sub connection { + my $self = shift; + @_ and $self->{_connection} = shift; + return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); } sub run_hooks { diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 4a84a30..b39373a 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -6,8 +6,6 @@ package Qpsmtpd::SMTP; use strict; use Carp; -use Qpsmtpd::Connection; -use Qpsmtpd::Transaction; use Qpsmtpd::Plugin; use Qpsmtpd::Constants; use Qpsmtpd::Auth; @@ -32,7 +30,7 @@ sub new { my $self = bless ({ args => \%args }, $class); my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit); - my (%commands); @commands{@commands} = ('') x @commands; + my (%commands); @commands{@commands} = (1) x @commands; # this list of valid commands should probably be a method or a set of methods $self->{_commands} = \%commands; @@ -130,25 +128,6 @@ sub connect_respond { } } -sub transaction { - my $self = shift; - return $self->{_transaction} || $self->reset_transaction(); -} - -sub reset_transaction { - my $self = shift; - $self->run_hooks("reset_transaction") if $self->{_transaction}; - return $self->{_transaction} = Qpsmtpd::Transaction->new(); -} - - -sub connection { - my $self = shift; - @_ and $self->{_connection} = shift; - return $self->{_connection} || ($self->{_connection} = Qpsmtpd::Connection->new()); -} - - sub helo { my ($self, $hello_host, @stuff) = @_; return $self->respond (501, @@ -217,9 +196,7 @@ sub ehlo_respond { $conn->hello_host($hello_host); $self->transaction; - my @capabilities = $self->transaction->notes('capabilities') - ? @{ $self->transaction->notes('capabilities') } - : (); + my @capabilities = @{ $self->transaction->notes('capabilities') }; # Check for possible AUTH mechanisms my %auth_mechanisms; @@ -237,7 +214,7 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { if ( %auth_mechanisms ) { push @capabilities, 'AUTH '.join(" ",keys(%auth_mechanisms)); - $self->{_commands}->{'auth'} = ""; + $self->{_commands}->{'auth'} = "1"; } $self->respond(250, From 8bb7cf67deaec1a732b3a4cab24129d3b0df8661 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sat, 30 Jul 2005 07:19:17 +0000 Subject: [PATCH 065/106] Add a caution about using large wait times in check_earlytalker; some superficial research suggests that some MTAs have unexpectedly short timeouts waiting for SMTP greetings (default of 30sec for Exim4.5, most notably) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@534 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/check_earlytalker | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index c356dc5..feec4d8 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -20,7 +20,11 @@ on all mail/rcpt commands in the transaction. =item wait [integer] The number of seconds to delay the initial greeting to see if the connecting -host speaks first. The default is 1. +host speaks first. The default is 1. Do not select a value that is too high, +or you may be unable to receive mail from MTAs with short SMTP connect or +greeting timeouts -- these are known to range as low as 30 seconds, and may +in some cases be configured lower by mailserver admins. Network transit time +must also be allowed for. =item action [string: deny, denysoft, log] From 4cdae6bf0554cd59bc076e47237e0de843816b11 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 31 Jul 2005 08:42:43 +0000 Subject: [PATCH 066/106] Merge daemonization support from 0.31 branch. Removed its -d commandline switch since the debug switch is already using it. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@538 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index a0f6cf5..3deb06b 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -25,6 +25,7 @@ my @LOCALADDR; # ip address(es) to bind to my $USER = 'smtpd'; # user to suid to my $MAXCONNIP = 5; # max simultaneous connections from one IP my $PID_FILE = ''; # file to which server PID will be written +my $DETACH; # daemonize on startup our $DEBUG = 0; sub usage { @@ -38,6 +39,7 @@ usage: qpsmtpd-forkserver [ options ] -u, --user U : run as a particular user (default 'smtpd') -m, --max-from-ip M : limit connections from a single IP; default 5 --pid-file P : print main servers PID to file P + --detach : detach from controlling terminal (daemonize) EOT exit 0; } @@ -50,6 +52,7 @@ GetOptions('h|help' => \&usage, 'u|user=s' => \$USER, 'pid-file=s' => \$PID_FILE, 'd|debug+' => \$DEBUG, + 'detach' => \$DETACH, ) || &usage; # detaint the commandline @@ -125,8 +128,6 @@ if ($PID_FILE) { open PID, ">$PID_FILE" or die "open pid_file: $!\n"; } - print PID $$,"\n"; - close PID; } # Load plugins here @@ -157,6 +158,20 @@ $> = $quid; ', group '. (getgrgid($)) || $))); +if ($DETACH) { + open STDIN, '/dev/null' or die "/dev/null: $!"; + open STDOUT, '>/dev/null' or die "/dev/null: $!"; + open STDERR, '>&STDOUT' or die "open(stderr): $!"; + defined (my $pid = fork) or die "fork: $!"; + exit 0 if $pid; + POSIX::setsid or die "setsid: $!"; +} + +if ($PID_FILE) { + print PID $$,"\n"; + close PID; +} + while (1) { REAPER(); my $running = scalar keys %childstatus; From 4a6f5dd2f034a6397372bd894bfd62a27704c132 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 31 Jul 2005 08:48:04 +0000 Subject: [PATCH 067/106] Merge r529 from 0.31 branch (explicit config dir via $QPSMTPD_CONFIG). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@539 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 3af5ed6..99861d8 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -116,6 +116,10 @@ sub config_dir { my $configdir = ($ENV{QMAIL} || '/var/qmail') . '/control'; my ($name) = ($0 =~ m!(.*?)/([^/]+)$!); $configdir = "$name/config" if (-e "$name/config/$config"); + if (exists $ENV{QPSMTPD_CONFIG}) { + $ENV{QPSMTPD_CONFIG} =~ /^(.*)$/; # detaint + $configdir = $1 if -e "$1/$config"; + } return $configdir; } From ff4c5d1ff2d6a6855e51eee26a3cd288aa0afca2 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 31 Jul 2005 09:02:42 +0000 Subject: [PATCH 068/106] Merge r536 from 0.31 branch (silence uninitialized-value warning on zero-length PID file) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@540 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 3deb06b..dba0731 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -113,7 +113,7 @@ if ($PID_FILE) { if (-e $PID_FILE) { open PID, "+<$PID_FILE" or die "open pid_file: $!\n"; - my $running_pid = ; chomp $running_pid; + my $running_pid = || ''; chomp $running_pid; if ($running_pid =~ /(\d+)/) { $running_pid = $1; if (kill 0, $running_pid) { From 79ecf24218192b739ac4cfffae5cbe235930bf82 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 15 Aug 2005 17:58:41 +0000 Subject: [PATCH 069/106] Fix for tls enabling auth - this is kind of hacky, and I'd prefer to fix this nastiness in the auth support instead. But this works for now. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@541 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/tls | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/plugins/tls b/plugins/tls index df094f4..4d14e19 100644 --- a/plugins/tls +++ b/plugins/tls @@ -40,6 +40,21 @@ sub init { ) or die "Could not create SSL context: $!"; $self->ssl_context($ssl_ctx); + + # Check for possible AUTH mechanisms +HOOK: foreach my $hook ( keys %{$qp->{hooks}} ) { + if ( $hook =~ m/^auth-?(.+)?$/ ) { + if ( defined $1 ) { + my $hooksub = "hook_$hook"; + $hooksub =~ s/\W/_/g; + *$hooksub = \&bad_ssl_hook; + } + else { # at least one polymorphous auth provider + *hook_auth = \&bad_ssl_hook; + } + } + } + } sub hook_ehlo { @@ -143,4 +158,4 @@ sub bad_ssl_hook { return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed'); return DECLINED; } -*hook_helo = *hook_data = *hook_rcpt = *hook_mail = *hook_auth = \&bad_ssl_hook; +*hook_helo = *hook_data = *hook_rcpt = *hook_mail = \&bad_ssl_hook; From 22fef51c19d7886b5c73250b6db3baa681235531 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Fri, 26 Aug 2005 09:51:57 +0000 Subject: [PATCH 070/106] Detaint %ENV somewhat more thoroughly (derived from perl5.8.7 perlsec POD). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@545 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index dba0731..867f730 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -68,7 +68,7 @@ for (0..$#LOCALADDR) { if ($USER =~ /^([\w\-]+)$/) { $USER = $1 } else { &usage } if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &usage } -delete $ENV{ENV}; +delete @ENV{'ENV','CDPATH','IFS','BASH_ENV'}; $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; my %childstatus = (); From 0a397e74a9c8470bb4b96c50881234fdf3b82ca5 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 26 Oct 2005 19:09:04 +0000 Subject: [PATCH 071/106] Support all resolvers in resolv.conf, and issue retries on errors the same way gethostbyname() does. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@555 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS/Resolver.pm | 256 ++++++++++++++++++++++++++------------ 1 file changed, 179 insertions(+), 77 deletions(-) diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 48526a7..34c9e15 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -3,7 +3,7 @@ package Danga::DNS::Resolver; use base qw(Danga::Socket); -use fields qw(res dst id_to_asker id_to_query timeout cache cache_timeout); +use fields qw(res dst cache cache_timeout queries); use Net::DNS; use Socket; @@ -30,16 +30,16 @@ sub new { ) || die "Cannot create socket: $!"; IO::Handle::blocking($sock, 0); - trace(2, "Using nameserver $res->{nameservers}->[0]:$res->{port}\n"); - my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton($res->{'nameservers'}->[0])); - #my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton('127.0.0.1')); - #my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton('10.2.1.20')); + $self->{dst} = []; + + foreach my $ns (@{ $res->{nameservers} }) { + trace(2, "Using nameserver $ns:$res->{port}\n"); + my $dst_sockaddr = sockaddr_in($res->{'port'}, inet_aton($ns)); + push @{$self->{dst}}, $dst_sockaddr; + } $self->{res} = $res; - $self->{dst} = $dst_sockaddr; - $self->{id_to_asker} = {}; - $self->{id_to_query} = {}; - $self->{timeout} = {}; + $self->{queries} = {}; $self->{cache} = {}; $self->{cache_timeout} = {}; @@ -52,10 +52,17 @@ sub new { return $self; } +sub ns { + my Danga::DNS::Resolver $self = shift; + my $index = shift; + return if $index > $#{$self->{dst}}; + return $self->{dst}->[$index]; +} + sub pending { my Danga::DNS::Resolver $self = shift; - return keys(%{$self->{id_to_asker}}); + return keys(%{$self->{queries}}); } sub _query { @@ -73,20 +80,14 @@ sub _query { } my $packet = $self->{res}->make_query_packet($host, $type); + my $packet_data = $packet->data; + my $id = $packet->header->id; - my $h = $packet->header; - my $id = $h->id; - - if (!$self->sock->send($packet_data, 0, $self->{dst})) { - return; - } - - trace(2, "Query: $host ($id)\n"); - - $self->{id_to_asker}->{$id} = $asker; - $self->{id_to_query}->{$id} = $host; - $self->{timeout}->{$id} = $now; + my $query = Danga::DNS::Resolver::Query->new( + $self, $asker, $host, $type, $now, $id, $packet_data, + ) or return; + $self->{queries}->{$id} = $query; return 1; } @@ -97,15 +98,12 @@ sub query_txt { my $now = time(); - trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve TXT: @hosts\n"); + trace(2, "trying to resolve TXT: @hosts\n"); foreach my $host (@hosts) { $self->_query($asker, $host, 'TXT', $now) || return; } - #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . - # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; - return 1; } @@ -115,15 +113,12 @@ sub query_mx { my $now = time(); - trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve MX: @hosts\n"); + trace(2, "trying to resolve MX: @hosts\n"); foreach my $host (@hosts) { $self->_query($asker, $host, 'MX', $now) || return; } - #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . - # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; - return 1; } @@ -133,15 +128,12 @@ sub query { my $now = time(); - trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve A/PTR: @hosts\n"); + trace(2, "trying to resolve A/PTR: @hosts\n"); foreach my $host (@hosts) { $self->_query($asker, $host, 'A', $now) || return; } - #print "+Pending queries: " . keys(%{$self->{id_to_asker}}) . - # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; - return 1; } @@ -154,20 +146,20 @@ sub _do_cleanup { my $idle = $self->max_idle_time; my @to_delete; - while (my ($id, $t) = each(%{$self->{timeout}})) { - if ($t < ($now - $idle)) { + while (my ($id, $obj) = each(%{$self->{queries}})) { + if ($obj->{timeout} < ($now - $idle)) { push @to_delete, $id; } } foreach my $id (@to_delete) { - delete $self->{timeout}{$id}; - my $asker = delete $self->{id_to_asker}{$id}; - my $query = delete $self->{id_to_query}{$id}; - $asker->run_callback("NXDOMAIN", $query); + my $query = delete $self->{queries}{$id}; + $query->timeout() and next; + # add back in if timeout caused us to loop to next server + $self->{queries}->{$id} = $query; } - foreach my $type ('A', 'TXT') { + foreach my $type ('A', 'TXT', 'MX') { @to_delete = (); while (my ($query, $t) = each(%{$self->{cache_timeout}{$type}})) { @@ -199,17 +191,14 @@ sub event_read { my $header = $packet->header; my $id = $header->id; - my $asker = delete $self->{id_to_asker}->{$id}; - my $query = delete $self->{id_to_query}->{$id}; - delete $self->{timeout}{$id}; - - #print "-Pending queries: " . keys(%{$self->{id_to_asker}}) . - # " / Cache Size: " . keys(%{$self->{cache}}) . "\n"; - if (!$asker) { - trace(1, "No asker for id: $id\n"); + my $qobj = delete $self->{queries}->{$id}; + if (!$qobj) { + trace(1, "No query for id: $id\n"); return; } + my $query = $qobj->{host}; + my $now = time(); my @questions = $packet->question; #print STDERR "response to ", $questions[0]->string, "\n"; @@ -217,61 +206,64 @@ sub event_read { # my $q = shift @questions; if ($rr->type eq "PTR") { my $rdns = $rr->ptrdname; - if ($query) { - # NB: Cached as an "A" lookup as there's no overlap and they - # go through the same query() function above - $self->{cache}{A}{$query} = $rdns; - $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long - } - $asker->run_callback($rdns, $query); + # NB: Cached as an "A" lookup as there's no overlap and they + # go through the same query() function above + $self->{cache}{A}{$query} = $rdns; + # $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + $self->{cache_timeout}{A}{$query} = $now + $rr->ttl; + $qobj->run_callback($rdns); } elsif ($rr->type eq "A") { my $ip = $rr->address; - if ($query) { - $self->{cache}{A}{$query} = $ip; - $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long - } - $asker->run_callback($ip, $query); + $self->{cache}{A}{$query} = $ip; + # $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + $self->{cache_timeout}{A}{$query} = $now + $rr->ttl; + $qobj->run_callback($ip); } elsif ($rr->type eq "TXT") { my $txt = $rr->txtdata; - if ($query) { - $self->{cache}{TXT}{$query} = $txt; - $self->{cache_timeout}{TXT}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long - } - $asker->run_callback($txt, $query); + $self->{cache}{TXT}{$query} = $txt; + # $self->{cache_timeout}{TXT}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long + $self->{cache_timeout}{TXT}{$query} = $now + $rr->ttl; + $qobj->run_callback($txt); + } + elsif ($rr->type eq "MX") { + my $host = $rr->exchange; + my $preference = $rr->preference; + $self->{cache}{MX}{$query} = [$host, $preference]; + $self->{cache_timeout}{MX}{$query} = $now + $rr->ttl; + $qobj->run_callback([$host, $preference]); } else { # came back, but not a PTR or A record - $asker->run_callback("unknown", $query); + $qobj->run_callback("UNKNOWN"); } $answers++; } if (!$answers) { if ($err eq "NXDOMAIN") { # trace("found => NXDOMAIN\n"); - $asker->run_callback("NXDOMAIN", $query); + $qobj->run_callback("NXDOMAIN"); } elsif ($err eq "SERVFAIL") { # try again??? - print "SERVFAIL looking for $query (Pending: " . keys(%{$self->{id_to_asker}}) . ")\n"; + print "SERVFAIL looking for $query\n"; #$self->query($asker, $query); - $asker->run_callback($err, $query); - #$self->{id_to_asker}->{$id} = $asker; - #$self->{id_to_query}->{$id} = $query; - #$self->{timeout}{$id} = time(); - + $qobj->error($err) and next; + # add back in if error() resulted in query being re-issued + $self->{queries}->{$id} = $qobj; } elsif ($err eq "NOERROR") { - $asker->run_callback($err, $query); + $qobj->run_callback($err); } elsif($err) { print("error: $err\n"); - $asker->run_callback($err, $query); + $qobj->error($err) and next; + $self->{queries}->{$id} = $qobj; } else { # trace("no answers\n"); - $asker->run_callback("NXDOMAIN", $query); + $qobj->run_callback("NOANSWER"); } } } @@ -286,6 +278,116 @@ sub close { # confess "Danga::DNS::Resolver socket should never be closed!"; } +package Danga::DNS::Resolver::Query; + +use constant MAX_QUERIES => 10; + +sub trace { + my $level = shift; + print ("$::DEBUG/$level [$$] dns lookup: @_") if $::DEBUG >= $level; +} + +sub new { + my ($class, $res, $asker, $host, $type, $now, $id, $data) = @_; + + my $self = { + resolver => $res, + asker => $asker, + host => $host, + type => $type, + timeout => $now, + id => $id, + data => $data, + repeat => 2, # number of retries + ns => 0, + nqueries => 0, + }; + + trace(2, "NS Query: $host ($id)\n"); + + bless $self, $class; + + $self->send_query || return; + + return $self; +} + +#sub DESTROY { +# my $self = shift; +# trace(2, "DESTROY $self\n"); +#} + +sub timeout { + my $self = shift; + + trace(2, "NS Query timeout. Trying next host\n"); + if ($self->send_query) { + # had another NS to send to, reset timeout + $self->{timeout} = time(); + return; + } + + # can we loop/repeat? + if (($self->{nqueries} <= MAX_QUERIES) && + ($self->{repeat} > 1)) + { + trace(2, "NS Query timeout. Next host failed. Trying loop\n"); + $self->{repeat}--; + $self->{ns} = 0; + return $self->timeout(); + } + + trace(2, "NS Query timeout. All failed. Running callback(TIMEOUT)\n"); + # otherwise we really must timeout. + $self->run_callback("TIMEOUT"); + return 1; +} + +sub error { + my ($self, $error) = @_; + + trace(2, "NS Query error. Trying next host\n"); + if ($self->send_query) { + # had another NS to send to, reset timeout + $self->{timeout} = time(); + return; + } + + # can we loop/repeat? + if (($self->{nqueries} <= MAX_QUERIES) && + ($self->{repeat} > 1)) + { + trace(2, "NS Query error. Next host failed. Trying loop\n"); + $self->{repeat}--; + $self->{ns} = 0; + return $self->error($error); + } + + trace(2, "NS Query error. All failed. Running callback($error)\n"); + # otherwise we really must timeout. + $self->run_callback($error); + return 1; +} + +sub run_callback { + my ($self, $response) = @_; + trace(2, "NS Query callback($self->{host} = $response\n"); + $self->{asker}->run_callback($response, $self->{host}); +} + +sub send_query { + my ($self) = @_; + + my $dst = $self->{resolver}->ns($self->{ns}++); + return unless defined $dst; + if (!$self->{resolver}->sock->send($self->{data}, 0, $dst)) { + return; + } + + $self->{nqueries}++; + return 1; +} + 1; =head1 NAME From a405e64e1c2c5be81f19cf04f07ccebb498a9410 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 11 Nov 2005 14:28:47 +0000 Subject: [PATCH 072/106] Allow any type of query Refactor some repeated code git-svn-id: https://svn.perl.org/qpsmtpd/trunk@561 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS.pm | 6 ++++- lib/Danga/DNS/Resolver.pm | 54 +++++++++++++++++++++------------------ 2 files changed, 34 insertions(+), 26 deletions(-) diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm index dc8128a..1e3a55c 100644 --- a/lib/Danga/DNS.pm +++ b/lib/Danga/DNS.pm @@ -62,7 +62,11 @@ sub new { } } else { - die "Unsupported DNS query type: $options{type}"; + if (!$resolver->query_type($self, $options{type}, @{$self->{hosts}})) { + $client->enable_read() if $client; + return; + } + # die "Unsupported DNS query type: $options{type}"; } } else { diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 34c9e15..473d0c4 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -92,6 +92,21 @@ sub _query { return 1; } +sub query_type { + my Danga::DNS::Resolver $self = shift; + my ($asker, $type, @hosts) = @_; + + my $now = time(); + + trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve $type: @hosts\n"); + + foreach my $host (@hosts) { + $self->_query($asker, $host, $type, $now) || return; + } + + return 1; +} + sub query_txt { my Danga::DNS::Resolver $self = shift; my ($asker, @hosts) = @_; @@ -182,6 +197,15 @@ sub max_idle_time { 30 } sub event_err { shift->close("dns socket error") } sub event_hup { shift->close("dns socket error") } +my %type_to_host = ( + PTR => 'ptrdname', + A => 'address', + AAAA => 'address', + TXT => 'txtdata', + NS => 'nsdname', + CNAME => 'cname', +); + sub event_read { my Danga::DNS::Resolver $self = shift; @@ -200,32 +224,12 @@ sub event_read { my $query = $qobj->{host}; my $now = time(); - my @questions = $packet->question; - #print STDERR "response to ", $questions[0]->string, "\n"; foreach my $rr ($packet->answer) { - # my $q = shift @questions; - if ($rr->type eq "PTR") { - my $rdns = $rr->ptrdname; - # NB: Cached as an "A" lookup as there's no overlap and they - # go through the same query() function above - $self->{cache}{A}{$query} = $rdns; - # $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long - $self->{cache_timeout}{A}{$query} = $now + $rr->ttl; - $qobj->run_callback($rdns); - } - elsif ($rr->type eq "A") { - my $ip = $rr->address; - $self->{cache}{A}{$query} = $ip; - # $self->{cache_timeout}{A}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long - $self->{cache_timeout}{A}{$query} = $now + $rr->ttl; - $qobj->run_callback($ip); - } - elsif ($rr->type eq "TXT") { - my $txt = $rr->txtdata; - $self->{cache}{TXT}{$query} = $txt; - # $self->{cache_timeout}{TXT}{$query} = $now + 60; # should use $rr->ttl but that would cache for too long - $self->{cache_timeout}{TXT}{$query} = $now + $rr->ttl; - $qobj->run_callback($txt); + if (my $host_method = $type_to_host{$rr->type}) { + my $host = $rr->$host_method; + $self->{cache}{$rr->type}{$query} = $host; + $self->{cache_timeout}{$rr->type}{$query} = $now + $rr->ttl; + $qobj->run_callback($host); } elsif ($rr->type eq "MX") { my $host = $rr->exchange; From 2af297f49c1dc2727744fa74d8f0172491568f39 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 11 Nov 2005 14:29:45 +0000 Subject: [PATCH 073/106] Fix for ignoring multiple dns returns git-svn-id: https://svn.perl.org/qpsmtpd/trunk@562 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/dnsbl | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index ca2c5d5..01c4106 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -34,7 +34,6 @@ sub connect_handler { my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); - $self->transaction->notes('pending_dns_queries', scalar(keys(%dnsbl_zones))); my $qp = $self->qp; for my $dnsbl (keys %dnsbl_zones) { # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp @@ -63,13 +62,10 @@ sub connect_handler { sub process_a_result { my ($qp, $template, $result, $query) = @_; - my $pending = $qp->transaction->notes('pending_dns_queries'); - $qp->transaction->notes('pending_dns_queries', --$pending); - warn("Result for A $query: $result\n"); if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { # NXDOMAIN or ERROR possibly... - $qp->finish_continuation unless $pending; + $qp->finish_continuation if $qp->input_sock->readable; return; } @@ -77,29 +73,26 @@ sub process_a_result { my $ip = $conn->remote_ip; $template =~ s/%IP%/$ip/g; $conn->notes('dnsbl', $template) unless $conn->notes('dnsbl'); - $qp->finish_continuation unless $pending; + $qp->finish_continuation if $qp->input_sock->readable; } sub process_txt_result { my ($qp, $result, $query) = @_; - my $pending = $qp->transaction->notes('pending_dns_queries'); - $qp->transaction->notes('pending_dns_queries', --$pending); - warn("Result for TXT $query: $result\n"); if ($result !~ /[a-z]/) { # NXDOMAIN or ERROR probably... - $qp->finish_continuation unless $pending; + $qp->finish_continuation if $qp->input_sock->readable; return; } my $conn = $qp->connection; $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl'); - $qp->finish_continuation unless $pending; + $qp->finish_continuation if $qp->input_sock->readable; } sub pickup_handler { - my ($self, $transaction, $rcpt) = @_; + my ($self, $transaction) = @_; # RBLSMTPD being non-empty means it contains the failure message to return if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { From a46a0345d5b3547be5f3236249d2fd7b03d4283a Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Sun, 13 Nov 2005 23:46:03 +0000 Subject: [PATCH 074/106] Fix for removed pseudo hash git-svn-id: https://svn.perl.org/qpsmtpd/trunk@563 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS/Resolver.pm | 24 +++--------------------- 1 file changed, 3 insertions(+), 21 deletions(-) diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 473d0c4..ce9fb7f 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -98,7 +98,7 @@ sub query_type { my $now = time(); - trace(2, "[" . keys(%{$self->{id_to_asker}}) . "] trying to resolve $type: @hosts\n"); + trace(2, "Trying to resolve $type: @hosts\n"); foreach my $host (@hosts) { $self->_query($asker, $host, $type, $now) || return; @@ -110,31 +110,13 @@ sub query_type { sub query_txt { my Danga::DNS::Resolver $self = shift; my ($asker, @hosts) = @_; - - my $now = time(); - - trace(2, "trying to resolve TXT: @hosts\n"); - - foreach my $host (@hosts) { - $self->_query($asker, $host, 'TXT', $now) || return; - } - - return 1; + return $self->query_type($asker, "TXT", @hosts); } sub query_mx { my Danga::DNS::Resolver $self = shift; my ($asker, @hosts) = @_; - - my $now = time(); - - trace(2, "trying to resolve MX: @hosts\n"); - - foreach my $host (@hosts) { - $self->_query($asker, $host, 'MX', $now) || return; - } - - return 1; + return $self->query_type($asker, "MX", @hosts); } sub query { From 8454ed40bc37d14451ddea3366b0ad60817ffb77 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 16 Nov 2005 15:04:37 +0000 Subject: [PATCH 075/106] With PollServer, I get several unrecognized commands before the disconnect from plugins/count_unrecognized_commands kicks in. Several buffered lines are read and processed by Danga::Client::process_read_buf() without checking if the socket was closed. The attached patch seems to fix it. -- Brian Grossman git-svn-id: https://svn.perl.org/qpsmtpd/trunk@571 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index 9e4d64a..c1ceabd 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -111,6 +111,7 @@ sub process_read_buf { sub readable { my Danga::Client $self = shift; return 0 if $self->{disable_read} > 0; + return 0 if $self->{closed} > 0; return 1; } From 5994a79d9fad652373359f27cfddc46a4467f5e2 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 22 Nov 2005 23:03:05 +0000 Subject: [PATCH 076/106] Slight cleanup. Support a finished() callback as the readable() thing didn't work. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@577 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS.pm | 24 +++++------------------- plugins/dnsbl | 15 +++++++++++---- 2 files changed, 16 insertions(+), 23 deletions(-) diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm index 1e3a55c..02cd525 100644 --- a/lib/Danga/DNS.pm +++ b/lib/Danga/DNS.pm @@ -33,34 +33,17 @@ sub new { $self->{num_hosts} = scalar(@{$self->{hosts}}) || "No hosts supplied"; $self->{client} = $client; $self->{callback} = $options{callback} || die "No callback given"; + $self->{finished} = $options{finished}; $self->{results} = {}; $self->{start} = time; if ($options{type}) { - if ($options{type} eq 'TXT') { - if (!$resolver->query_txt($self, @{$self->{hosts}})) { - $client->enable_read() if $client; - return; - } - } - elsif ($options{type} eq 'A') { + if ( ($options{type} eq 'A') || ($options{type} eq 'PTR') ) { if (!$resolver->query($self, @{$self->{hosts}})) { $client->enable_read() if $client; return; } } - elsif ($options{type} eq 'PTR') { - if (!$resolver->query($self, @{$self->{hosts}})) { - $client->enable_read() if $client; - return; - } - } - elsif ($options{type} eq 'MX') { - if (!$resolver->query_mx($self, @{$self->{hosts}})) { - $client->enable_read() if $client; - return; - } - } else { if (!$resolver->query_type($self, $options{type}, @{$self->{hosts}})) { $client->enable_read() if $client; @@ -102,6 +85,9 @@ sub DESTROY { } } $self->{client}->enable_read if $self->{client}; + if ($self->{finished}) { + $self->{finished}->(); + } } 1; diff --git a/plugins/dnsbl b/plugins/dnsbl index 01c4106..d9b7c75 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -41,6 +41,7 @@ sub connect_handler { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background"); Danga::DNS->new( callback => sub { process_a_result($qp, $dnsbl_zones{$dnsbl}, @_) }, + finished => sub { finished($qp) }, host => "$reversed_ip.$dnsbl", type => 'A', client => $self->qp->input_sock, @@ -49,6 +50,7 @@ sub connect_handler { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background"); Danga::DNS->new( callback => sub { process_txt_result($qp, @_) }, + finished => sub { finished($qp) }, host => "$reversed_ip.$dnsbl", type => 'TXT', client => $self->qp->input_sock, @@ -59,13 +61,18 @@ sub connect_handler { return CONTINUATION; } +sub finished { + my ($qp) = @_; + $qp->finish_continuation; +} + sub process_a_result { my ($qp, $template, $result, $query) = @_; warn("Result for A $query: $result\n"); if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { # NXDOMAIN or ERROR possibly... - $qp->finish_continuation if $qp->input_sock->readable; + # $qp->finish_continuation if $qp->input_sock->readable; return; } @@ -73,7 +80,7 @@ sub process_a_result { my $ip = $conn->remote_ip; $template =~ s/%IP%/$ip/g; $conn->notes('dnsbl', $template) unless $conn->notes('dnsbl'); - $qp->finish_continuation if $qp->input_sock->readable; + # $qp->finish_continuation if $qp->input_sock->readable; } sub process_txt_result { @@ -82,13 +89,13 @@ sub process_txt_result { warn("Result for TXT $query: $result\n"); if ($result !~ /[a-z]/) { # NXDOMAIN or ERROR probably... - $qp->finish_continuation if $qp->input_sock->readable; + # $qp->finish_continuation if $qp->input_sock->readable; return; } my $conn = $qp->connection; $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl'); - $qp->finish_continuation if $qp->input_sock->readable; + # $qp->finish_continuation if $qp->input_sock->readable; } sub pickup_handler { From f5efe92bea643728310e8644b24f61c44c0051ad Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 22 Nov 2005 23:04:06 +0000 Subject: [PATCH 077/106] Forgot pseudo hash entry git-svn-id: https://svn.perl.org/qpsmtpd/trunk@578 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm index 02cd525..8b76bdd 100644 --- a/lib/Danga/DNS.pm +++ b/lib/Danga/DNS.pm @@ -6,7 +6,7 @@ package Danga::DNS; # hosts you want to query, plus the callback. All the hard work is done # in Danga::DNS::Resolver. -use fields qw(client hosts num_hosts callback results start); +use fields qw(client hosts num_hosts callback finished results start); use strict; use Danga::DNS::Resolver; From dfe9dda4547937f0cc1761822d4165e22477af34 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 22 Nov 2005 23:22:48 +0000 Subject: [PATCH 078/106] Don't run continuation if config git-svn-id: https://svn.perl.org/qpsmtpd/trunk@579 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 99861d8..7402a96 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -280,7 +280,7 @@ sub connection { sub run_hooks { my ($self, $hook) = (shift, shift); - if ($self->{_continuation} && $hook ne "logging") { + if ($self->{_continuation} && $hook ne "logging" && $hook ne "config") { die "Continuations in progress from previous hook (this is the $hook hook)"; } my $hooks = $self->{hooks}; From 8f7882d076638bb2ddc0b917e6ae9b469dc1cdf7 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 22 Nov 2005 23:43:08 +0000 Subject: [PATCH 079/106] Finally a working version :-/ git-svn-id: https://svn.perl.org/qpsmtpd/trunk@580 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/dnsbl | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/plugins/dnsbl b/plugins/dnsbl index d9b7c75..bbd5cd0 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -34,6 +34,7 @@ sub connect_handler { my $reversed_ip = join(".", reverse(split(/\./, $remote_ip))); + my $total_zones = keys %dnsbl_zones; my $qp = $self->qp; for my $dnsbl (keys %dnsbl_zones) { # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp @@ -41,7 +42,7 @@ sub connect_handler { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record in the background"); Danga::DNS->new( callback => sub { process_a_result($qp, $dnsbl_zones{$dnsbl}, @_) }, - finished => sub { finished($qp) }, + finished => sub { $total_zones--; finished($qp, $total_zones) }, host => "$reversed_ip.$dnsbl", type => 'A', client => $self->qp->input_sock, @@ -50,7 +51,7 @@ sub connect_handler { $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record in the background"); Danga::DNS->new( callback => sub { process_txt_result($qp, @_) }, - finished => sub { finished($qp) }, + finished => sub { $total_zones--; finished($qp, $total_zones) }, host => "$reversed_ip.$dnsbl", type => 'TXT', client => $self->qp->input_sock, @@ -62,8 +63,8 @@ sub connect_handler { } sub finished { - my ($qp) = @_; - $qp->finish_continuation; + my ($qp, $total_zones) = @_; + $qp->finish_continuation unless $total_zones; } sub process_a_result { From e1982f05d413118dbc47a64718919e03aa1f1743 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Mon, 28 Nov 2005 19:07:56 +0000 Subject: [PATCH 080/106] Fixed to use same subsystem as dnsbl plugin git-svn-id: https://svn.perl.org/qpsmtpd/trunk@581 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/require_resolvable_fromhost | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index a587bb5..a7a498f 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -28,11 +28,12 @@ sub check_dns { return DECLINED; } - $self->transaction->notes('pending_dns_queries', 2); + my $total_queries = 2; my $qp = $self->qp; $self->log(LOGDEBUG, "Checking $host for MX record in the background"); Danga::DNS->new( callback => sub { dns_result($qp, @_) }, + finished => sub { $total_queries--; finished($qp, $total_queries) }, host => $host, type => "MX", client => $qp->input_sock, @@ -40,19 +41,21 @@ sub check_dns { $self->log(LOGDEBUG, "Checking $host for A record in the background"); Danga::DNS->new( callback => sub { dns_result($qp, @_) }, + finished => sub { $total_queries--; finished($qp, $total_queries) }, host => $host, client => $qp->input_sock, ); return CONTINUATION; } +sub finished { + my ($qp, $total_zones) = @_; + $qp->finish_continuation unless $total_zones; +} sub dns_result { my ($qp, $result, $query) = @_; - my $pending = $qp->transaction->notes('pending_dns_queries'); - $qp->transaction->notes('pending_dns_queries', --$pending); - if ($result =~ /^[A-Z]+$/) { # probably an error $qp->log(LOGDEBUG, "DNS error: $result looking up $query"); @@ -60,8 +63,6 @@ sub dns_result { $qp->transaction->notes('resolvable', 1); $qp->log(LOGDEBUG, "DNS lookup $query returned: $result"); } - - $qp->finish_continuation unless $pending; } From cc45e9a576881c22a62996267bda363bc524f3e9 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 2 Dec 2005 02:35:14 +0000 Subject: [PATCH 081/106] Prevent logging plugins from entering an infinite loop (use {_transaction} rather than ->transaction() when passing to hook) Merge some other changes from 0.31.1 branch git-svn-id: https://svn.perl.org/qpsmtpd/trunk@582 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 110 +++++++++++++++++++++++++++++++++++-------------- 1 file changed, 78 insertions(+), 32 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 7402a96..9914f10 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -17,6 +17,7 @@ sub load_logging { # need to do this differently that other plugins so as to # not trigger logging activity my $self = shift; + #warn("load_logging: $self->{hooks}{logging} ", caller(8), "\n"); return if $self->{hooks}->{"logging"}; my $configdir = $self->config_dir("logging"); my $configfile = "$configdir/logging"; @@ -75,7 +76,9 @@ sub varlog { unless ( $rc and $rc == DECLINED or $rc == OK ) { # no logging plugins registered so fall back to STDERR + my $fd = $self->{fd}; warn join(" ", $$ . + (defined $fd ? " fd:$fd" : "") . (defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" : ""), @log), "\n" @@ -161,26 +164,92 @@ sub get_qmail_config { } sub _config_from_file { - my ($self, $configfile, $config) = @_; + my ($self, $configfile, $config, $visited) = @_; return unless -e $configfile; + + $visited ||= []; + push @{$visited}, $configfile; + open CF, "<$configfile" or warn "$$ could not open configfile $configfile: $!" and return; my @config = ; chomp @config; @config = grep { length($_) and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config; close CF; - #$self->log(10, "returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)])); + + my $pos = 0; + while ($pos < @config) { + # recursively pursue an $include reference, if found. An inclusion which + # begins with a leading slash is interpreted as a path to a file and will + # supercede the usual config path resolution. Otherwise, the normal + # config_dir() lookup is employed (the location in which the inclusion + # appeared receives no special precedence; possibly it should, but it'd + # be complicated beyond justifiability for so simple a config system. + if ($config[$pos] =~ /^\s*\$include\s+(\S+)\s*$/) { + my ($includedir, $inclusion) = ('', $1); + + splice @config, $pos, 1; # remove the $include line + if ($inclusion !~ /^\//) { + $includedir = $self->config_dir($inclusion); + $inclusion = "$includedir/$inclusion"; + } + + if (grep($_ eq $inclusion, @{$visited})) { + $self->log(LOGERROR, "Circular \$include reference in config $config:"); + $self->log(LOGERROR, "From $visited->[0]:"); + $self->log(LOGERROR, " includes $_") + for (@{$visited}[1..$#{$visited}], $inclusion); + return wantarray ? () : undef; + } + push @{$visited}, $inclusion; + + for my $inc ($self->expand_inclusion_($inclusion, $configfile)) { + my @insertion = $self->_config_from_file($inc, $config, $visited); + splice @config, $pos, 0, @insertion; # insert the inclusion + $pos += @insertion; + } + } else { + $pos++; + } + } + $self->{_config_cache}->{$config} = \@config; + return wantarray ? @config : $config[0]; } -our $HOOKS; +sub expand_inclusion_ { + my $self = shift; + my $inclusion = shift; + my $context = shift; + my @includes; + + if (-d $inclusion) { + $self->log(LOGDEBUG, "inclusion of directory $inclusion from $context"); + + if (opendir(INCD, $inclusion)) { + @includes = map { "$inclusion/$_" } + (grep { -f "$inclusion/$_" and !/^\./ } readdir INCD); + closedir INCD; + } else { + $self->log(LOGERROR, "Couldn't open directory $inclusion,". + " referenced from $context ($!)"); + } + } else { + $self->log(LOGDEBUG, "inclusion of file $inclusion from $context"); + @includes = ( $inclusion ); + } + return @includes; +} + + +#our $HOOKS; sub load_plugins { my $self = shift; - if ($HOOKS) { - return $self->{hooks} = $HOOKS; - } +# if ($HOOKS) { +# return $self->{hooks} = $HOOKS; +# } $self->log(LOGWARN, "Plugins already loaded") if $self->{hooks}; $self->{hooks} = {}; @@ -192,8 +261,8 @@ sub load_plugins { @plugins = $self->_load_plugins($dir, @plugins); - $HOOKS = $self->{hooks}; - +# $HOOKS = $self->{hooks}; +# return @plugins; } @@ -205,28 +274,6 @@ sub _load_plugins { for my $plugin_line (@plugins) { my ($plugin, @args) = split ' ', $plugin_line; - if (lc($plugin) eq '$include') { - my $inc = shift @args; - my $config_dir = $self->config_dir($inc); - if (-d "$config_dir/$inc") { - $self->log(LOGDEBUG, "Loading include dir: $config_dir/$inc"); - opendir(DIR, "$config_dir/$inc") || die "opendir($config_dir/$inc): $!"; - my @plugconf = sort grep { -f $_ } map { "$config_dir/$inc/$_" } grep { !/^\./ } readdir(DIR); - closedir(DIR); - foreach my $f (@plugconf) { - push @ret, $self->_load_plugins($dir, $self->_config_from_file($f, "plugins")); - } - } - elsif (-f "$config_dir/$inc") { - $self->log(LOGDEBUG, "Loading include file: $config_dir/$inc"); - push @ret, $self->_load_plugins($dir, $self->_config_from_file("$config_dir/$inc", "plugins")); - } - else { - $self->log(LOGCRIT, "CRITICAL PLUGIN CONFIG ERROR: Include $config_dir/$inc not found"); - } - next; - } - my $plugin_name = $plugin; $plugin =~ s/:\d+$//; # after this point, only used for filename @@ -335,13 +382,12 @@ sub run_hook { my ($self, $hook, $code, @args) = @_; my @r; if ( $hook eq 'logging' ) { # without calling $self->log() - eval { (@r) = $code->{code}->($self, $self->transaction, @_); }; + eval { (@r) = $code->{code}->($self, $self->{_transaction}, @_); }; $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; } else { $self->varlog(LOGINFO, $hook, $code->{name}); eval { (@r) = $code->{code}->($self, $self->transaction, @args); }; - $@ and $self->log(LOGCRIT, "FATAL PLUGIN ERROR: ", $@) and return; !defined $r[0] From bf5eea44c246b33c59857941e7a2f1a7544f26f5 Mon Sep 17 00:00:00 2001 From: Devin Carraway Date: Sun, 11 Dec 2005 09:14:20 +0000 Subject: [PATCH 082/106] Merge r584 from 0.3x branch (drop root privs in forkserver before loading plugins) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@585 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 867f730..761e17f 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -132,7 +132,6 @@ if ($PID_FILE) { # Load plugins here my $qpsmtpd = Qpsmtpd::TcpServer->new(); -$qpsmtpd->load_plugins; # Drop privileges my (undef, undef, $quid, $qgid) = getpwnam $USER or @@ -141,7 +140,6 @@ my $groups = "$qgid $qgid"; while (my ($name,$passwd,$gid,$members) = getgrent()) { my @m = split(/ /, $members); if (grep {$_ eq $USER} @m) { - ::log(LOGINFO,"$USER is member of group $name($gid)"); $groups .= " $gid"; } } @@ -152,6 +150,8 @@ POSIX::setuid($quid) or die "unable to change uid: $!\n"; $> = $quid; +$qpsmtpd->load_plugins; + ::log(LOGINFO,"Listening on port $PORT"); ::log(LOGINFO, 'Running as user '. (getpwuid($>) || $>) . From 5910aa7292363287bbffe5daed7b22944bcd62c5 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 14 Dec 2005 01:21:20 +0000 Subject: [PATCH 083/106] Fix log bustage ($coworker) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@586 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 9914f10..ad56b36 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -382,7 +382,7 @@ sub run_hook { my ($self, $hook, $code, @args) = @_; my @r; if ( $hook eq 'logging' ) { # without calling $self->log() - eval { (@r) = $code->{code}->($self, $self->{_transaction}, @_); }; + eval { (@r) = $code->{code}->($self, $self->{_transaction}, @args); }; $@ and warn("FATAL LOGGING PLUGIN ERROR: ", $@) and next; } else { From 8ac6157ee8303042e1c2fd15aeb22f93c7d0730d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 16 Dec 2005 22:27:27 +0000 Subject: [PATCH 084/106] r2614@g5: ask | 2005-12-16 14:27:01 -0800 Make the clamdscan plugin temporarily deny mail if if can't talk to clamd (Filippo Carletti) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@587 958fd67b-6ff1-0310-b445-bb7760255be9 --- Changes | 6 ++++++ plugins/virus/clamdscan | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 4b5a02e..2d0eabd 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,9 @@ +0.40 + + Make the clamdscan plugin temporarily deny mail if if can't talk to clamd + (Filippo Carletti) + + 0.31 - qpsmtpd-forkserver: --listen-address may now be given more than once, to diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 1c35626..569b044 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -153,7 +153,7 @@ sub hook_data_post { $clamd = Clamd->new(); # default unix domain socket } - return (DECLINED) unless $clamd->ping(); + return (DENYSOFT) unless $clamd->ping(); if ( my %found = $clamd->scan($filename) ) { my $viruses = join( ",", values(%found) ); From 2535e772939f9f5f88aba016168d76e0e3abeac5 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 22 Dec 2005 21:30:53 +0000 Subject: [PATCH 085/106] Merge branches/0.3x back to trunk. Too many individual changes to document. Trust me... ;-) Lightly tested (i.e. it accepts and delivers mail with minimal plugins). NOTES/LIMITATIONS: logging/adaptive currently eats some log messages. auth_vpopmail_sql is currently broken (needs continuations?). 'make test' fails in dnsbl (no Test::Qpsmtpd::input_sock() method). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@588 958fd67b-6ff1-0310-b445-bb7760255be9 --- .perltidyrc | 16 ++ Changes | 43 ++++- MANIFEST | 5 + README | 8 +- STATUS | 4 +- config.sample/invalid_resolvable_fromhost | 6 + config.sample/size_threshold | 3 + lib/Qpsmtpd.pm | 29 +++- lib/Qpsmtpd/Address.pm | 200 ++++++++++++++++++---- lib/Qpsmtpd/Auth.pm | 18 +- lib/Qpsmtpd/Plugin.pm | 12 +- lib/Qpsmtpd/PollServer.pm | 2 + lib/Qpsmtpd/SMTP.pm | 18 +- lib/Qpsmtpd/TcpServer.pm | 2 +- lib/Qpsmtpd/Transaction.pm | 36 ++-- plugins/dnsbl | 28 ++- plugins/queue/exim-bsmtp | 138 +++++++++++++++ plugins/require_resolvable_fromhost | 23 ++- plugins/rhsbl | 11 +- plugins/tls | 17 +- plugins/virus/clamdscan | 7 +- qpsmtpd | 3 - qpsmtpd-forkserver | 33 ++-- t/qpsmtpd-address.t | 47 +++-- 24 files changed, 566 insertions(+), 143 deletions(-) create mode 100644 .perltidyrc create mode 100644 config.sample/invalid_resolvable_fromhost create mode 100644 config.sample/size_threshold create mode 100644 plugins/queue/exim-bsmtp diff --git a/.perltidyrc b/.perltidyrc new file mode 100644 index 0000000..65b29f2 --- /dev/null +++ b/.perltidyrc @@ -0,0 +1,16 @@ + +-i=4 # 4 space indentation (we used to use 2; in the future we'll use 4) +-ci=2 # continuation indention + +-pt=2 # tight parens +-sbt=2 # tight square parens +-bt=2 # tight curly braces +-bbt=0 # open code block curly braces + +-lp # line up with parentheses +-cti=1 # align closing parens with opening parens ("closing token placement") + +# -nolq # don't outdent long quotes (not sure if we should enable this) + + + diff --git a/Changes b/Changes index 2d0eabd..2b0ee83 100644 --- a/Changes +++ b/Changes @@ -1,10 +1,20 @@ 0.40 - Make the clamdscan plugin temporarily deny mail if if can't talk to clamd - (Filippo Carletti) +0.31.1 - 2005/11/18 + + Add missing files to the distribution, oops... (Thanks Budi Ang!) + (exim plugin, tls plugin, various sample configuration files) -0.31 - +0.31 - 2005/11/16 + + STARTTLS support (see plugins/tls) + + Added queue/exim-bsmtp plugin to spool accepted mail into an Exim + backend via BSMTP. (Devin Carraway) + + New plugin inheritance system, see the bottom of README.plugins for + more information qpsmtpd-forkserver: --listen-address may now be given more than once, to request listening on multiple local addresses (Devin Carraway) @@ -17,14 +27,41 @@ postfix backend, which expects to have write permission to a fifo which usually belongs to group postdrop). (pjh) + qpsmtpd-forkserver: if -d or --detach is given on the commandline, + forkserver will detach from the controlling terminal and daemonize + itself (Devin Carraway) + + replace some fun smtp comments with boring ones. + + example patterns for badrcptto plugin - Gordon Rowell + + Extend require_resolvable_fromhost to include a configurable list of + "impossible" addresses to combat spammer forging. (Hanno Hecker) + + Use qmail/control/smtpdgreeting if it exists, otherwise + show the original qpsmtpd greeting (with version information). + + Apply slight variation on patch from Peter Holzer to allow specification of + an explicit $QPSMTPD_CONFIG variable to specify where the config lives, + overriding $QMAIL/control and /var/qmail/control if set. The usual + "last location with the file wins" rule still applies. + + Refactor Qpsmtpd::Address + when disconncting with a temporary failure, return 421 rather than 450 or 451. (Peter J. Holzer) The unrecognized_command hook now uses DENY_DISCONNECT return for disconnecting the user. + If the environment variable $QPSMTPD_CONFIG is set, qpsmtpd will look + for its config files in the directory given therein, in addition to (and + in preference to) other locations. (Peter J. Holzer) + Updated documentation + Various minor cleanups + 0.30 - 2005/07/05 diff --git a/MANIFEST b/MANIFEST index ed0c5b2..36c41c1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,6 +1,8 @@ Changes config.sample/badhelo +config.sample/badrcptto_patterns config.sample/dnsbl_zones +config.sample/invalid_resolvable_fromhost config.sample/IP config.sample/logging config.sample/loglevel @@ -8,6 +10,7 @@ config.sample/plugins config.sample/relayclients config.sample/require_resolvable_fromhost config.sample/rhsbl_zones +config.sample/size_threshold CREDITS lib/Apache/Qpsmtpd.pm lib/Qpsmtpd.pm @@ -55,6 +58,7 @@ plugins/logging/adaptive plugins/logging/devnull plugins/logging/warn plugins/milter +plugins/queue/exim-bsmtp plugins/queue/maildir plugins/queue/postfix-queue plugins/queue/qmail-queue @@ -65,6 +69,7 @@ plugins/require_resolvable_fromhost plugins/rhsbl plugins/sender_permitted_from plugins/spamassassin +plugins/tls plugins/virus/aveclient plugins/virus/bitdefender plugins/virus/check_for_hi_virus diff --git a/README b/README index ae7588d..836b219 100644 --- a/README +++ b/README @@ -57,13 +57,9 @@ run the following command in the /home/smtpd/ directory. svn co http://svn.perl.org/qpsmtpd/trunk . -Or if you want a specific release, use for example +Beware that the trunk might be unstable and unsuitable for anything but development, so you might want to get a specific release, for example: - svn co http://svn.perl.org/qpsmtpd/tags/0.30 . - -In the branch L we -have an experimental event based version of qpsmtpd that can handle -thousands of simultaneous connections with very little overhead. + svn co http://svn.perl.org/qpsmtpd/tags/0.31.1 . chmod o+t ~smtpd/qpsmtpd/ (or whatever directory you installed qpsmtpd in) to make supervise start the log process. diff --git a/STATUS b/STATUS index 443745f..4616751 100644 --- a/STATUS +++ b/STATUS @@ -10,13 +10,15 @@ pez (or pezmail) Near term roadmap ================= -0.31: +0.32: - Bugfixes - add module requirements to the META.yml file 0.40: - Add user configuration plugin - Add plugin API for checking if a local email address is valid + - use keyword "ESMTPA" in Received header in case of authentication to comply with RFC 3848. + 0.50: Include the popular check_delivery[1] functionality via the 0.30 API diff --git a/config.sample/invalid_resolvable_fromhost b/config.sample/invalid_resolvable_fromhost new file mode 100644 index 0000000..db90eb8 --- /dev/null +++ b/config.sample/invalid_resolvable_fromhost @@ -0,0 +1,6 @@ +# include full network block including mask +127.0.0.0/8 +0.0.0.0/8 +224.0.0.0/4 +169.254.0.0/16 +10.0.0.0/8 diff --git a/config.sample/size_threshold b/config.sample/size_threshold new file mode 100644 index 0000000..a6a1fb4 --- /dev/null +++ b/config.sample/size_threshold @@ -0,0 +1,3 @@ +# Messages below the size below will be stored in memory and not spooled. +# Without this file, the default is 0 bytes, i.e. all messages will be spooled. +10000 diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index ad56b36..a47c4c6 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -1,13 +1,13 @@ package Qpsmtpd; use strict; -use vars qw($VERSION $Logger $TraceLevel $Spool_dir); +use vars qw($VERSION $Logger $TraceLevel $Spool_dir $Size_threshold); use Sys::Hostname; use Qpsmtpd::Constants; use Qpsmtpd::Transaction; use Qpsmtpd::Connection; -$VERSION = "0.31-dev"; +$VERSION = "0.40-dev"; sub version { $VERSION }; @@ -242,8 +242,6 @@ sub expand_inclusion_ { } -#our $HOOKS; - sub load_plugins { my $self = shift; @@ -480,6 +478,29 @@ sub temp_dir { return $dirname; } +sub size_threshold { + my $self = shift; + unless ( defined $Size_threshold ) { + $Size_threshold = $self->config('size_threshold') || 0; + $self->log(LOGNOTICE, "size_threshold set to $Size_threshold"); + } + return $Size_threshold; +} + +sub auth_user { + my ($self, $user) = @_; + $user =~ s/[\r\n].*//s; + $self->{_auth_user} = $user if $user; + return (defined $self->{_auth_user} ? $self->{_auth_user} : "" ); +} + +sub auth_mechanism { + my ($self, $mechanism) = @_; + $mechanism =~ s/[\r\n].*//s; + $self->{_auth_mechanism} = $mechanism if $mechanism; + return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); +} + 1; __END__ diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index 90f7530..6a8f28a 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/lib/Qpsmtpd/Address.pm @@ -1,16 +1,74 @@ +#!/usr/bin/perl -w package Qpsmtpd::Address; use strict; +=head1 NAME + +Qpsmtpd::Address - Lightweight E-Mail address objects + +=head1 DESCRIPTION + +Based originally on cut and paste from Mail::Address and including +every jot and tittle from RFC-2821/2822 on what is a legal e-mail +address for use during the SMTP transaction. + +=head1 USAGE + + my $rcpt = Qpsmtpd::Address->new(''); + +The objects created can be used as is, since they automatically +stringify to a standard form, and they have an overloaded comparison +for easy testing of values. + +=head1 METHODS + +=cut + +use overload ( + '""' => \&format, + 'cmp' => \&_addr_cmp, +); + +=head2 new() + +Can be called two ways: + +=over 4 + +=item * Qpsmtpd::Address->new('') + +The normal mode of operation is to pass the entire contents of the +RCPT TO: command from the SMTP transaction. The value will be fully +parsed via the L method, using the full RFC 2821 rules. + +=item * Qpsmtpd::Address->new("user", "host") + +If the caller has already split the address from the domain/host, +this mode will not L the input values. This is not +recommended in cases of user-generated input for that reason. This +can be used to generate Qpsmtpd::Address objects for accounts like +"" or indeed for the bounce address "<>". + +=back + +The resulting objects can be stored in arrays or used in plugins to +test for equality (like in badmailfrom). + +=cut + sub new { - my ($class, $address) = @_; - my $self = [ ]; - if ($address =~ /^<(.*)>$/) { - $self->[0] = $1; - } else { - $self->[0] = $address; + my ($class, $user, $host) = @_; + my $self = {}; + if ($user =~ /^<(.*)>$/ ) { + ($user, $host) = $class->canonify($user) } - bless ($self, $class); - return $self; + elsif ( not defined $host ) { + my $address = $user; + ($user, $host) = $address =~ m/(.*)(?:\@(.*))/; + } + $self->{_user} = $user; + $self->{_host} = $host; + return bless $self, $class; } # Definition of an address ("path") from RFC 2821: @@ -110,6 +168,15 @@ sub new { # # (We ignore all obs forms) +=head2 canonify() + +Primarily an internal method, it is used only on the path portion of +an e-mail message, as defined in RFC-2821 (this is the part inside the +angle brackets and does not include the "human readable" portion of an +address). It returns a list of (local-part, domain). + +=cut + sub canonify { my ($dummy, $path) = @_; my $atom = '[a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~]+'; @@ -131,60 +198,131 @@ sub canonify { # empty path is ok return "" if $path eq ""; - # + # bare postmaster is permissible, perl RFC-2821 (4.5.1) + return ("postmaster", undef) if $path eq "postmaster"; + my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/); - return undef unless defined $localpart; + return (undef) unless defined $localpart; if ($localpart =~ /^$atom(\.$atom)*/) { # simple case, we are done - return $path; + return ($localpart, $domainpart); } if ($localpart =~ /^"(($qtext|\\$text)*)"$/) { $localpart = $1; $localpart =~ s/\\($text)/$1/g; - return "$localpart\@$domainpart"; + return ($localpart, $domainpart); } - return undef; + return (undef); } +=head2 parse() +Retained as a compatibility method, it is completely equivalent +to new() called with a single parameter. -sub parse { - my ($class, $line) = @_; - my $a = $class->canonify($line); - return ($class->new($a)) if (defined $a); - return undef; +=cut + +sub parse { # retain for compatibility only + return shift->new(shift); } +=head2 address() + +Can be used to reset the value of an existing Q::A object, in which +case it takes a parameter with or without the angle brackets. + +Returns the stringified representation of the address. NOTE: does +not escape any of the characters that need escaping, nor does it +include the surrounding angle brackets. For that purpose, see +L. + +=cut + sub address { my ($self, $val) = @_; - my $oldval = $self->[0]; - return $self->[0] = $val if (defined($val)); - return $oldval; + if ( defined($val) ) { + $val = "<$val>" unless $val =~ /^<.+>$/; + my ($user, $host) = $self->canonify($val); + $self->{_user} = $user; + $self->{_host} = $host; + } + return ( defined $self->{_user} ? $self->{_user} : '' ) + . ( defined $self->{_host} ? '@'.$self->{_host} : '' ); } +=head2 format() + +Returns the canonical stringified representation of the address. It +does escape any characters requiring it (per RFC-2821/2822) and it +does include the surrounding angle brackets. It is also the default +stringification operator, so the following are equivalent: + + print $rcpt->format(); + print $rcpt; + +=cut + sub format { my ($self) = @_; my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]'; - my $s = $self->[0]; - return '<>' unless $s; - my ($user, $host) = $s =~ m/(.*)\@(.*)/; - if ($user =~ s/($qchar)/\\$1/g) { - return qq{<"$user"\@$host>}; + return '<>' unless defined $self->{_user}; + if ( ( my $user = $self->{_user}) =~ s/($qchar)/\\$1/g) { + return qq(<"$user") + . ( defined $self->{_host} ? '@'.$self->{_host} : '' ). ">"; } - return "<$s>"; + return "<".$self->address().">"; } +=head2 user() + +Returns the "localpart" of the address, per RFC-2821, or the portion +before the '@' sign. + +=cut + sub user { my ($self) = @_; - my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; - return $user; + return $self->{_user}; } +=head2 host() + +Returns the "domain" part of the address, per RFC-2821, or the portion +after the '@' sign. + +=cut + sub host { my ($self) = @_; - my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; - return $host; + return $self->{_host}; } +sub _addr_cmp { + require UNIVERSAL; + my ($left, $right, $swap) = @_; + my $class = ref($left); + + unless ( UNIVERSAL::isa($right, $class) ) { + $right = $class->new($right); + } + + #invert the address so we can sort by domain then user + $left = lc($left->host.'='.$left->user); + $right = lc($right->host.'='.$right->user); + + if ( $swap ) { + ($right, $left) = ($left, $right); + } + + return ($left cmp $right); +} + +=head1 COPYRIGHT + +Copyright 2004-2005 Peter J. Holzer. See the LICENSE file for more +information. + +=cut + 1; diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index ea28b92..ada6173 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -226,19 +226,6 @@ sub e64 return($res); } -sub Qpsmtpd::SMTP::auth { - my ( $self, $arg, @stuff ) = @_; - - #they AUTH'd once already - return $self->respond( 503, "but you already said AUTH ..." ) - if ( defined $self->{_auth} - and $self->{_auth} == OK ); - return $self->respond( 503, "AUTH not defined for HELO" ) - if ( $self->connection->hello eq "helo" ); - - return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); -} - sub SASL { # $DB::single = 1; @@ -326,9 +313,8 @@ sub SASL { $session->connection->relay_client(1); $session->log( LOGINFO, $msg ); - $session->{_auth_user} = $user; - $session->{_auth_mechanism} = $mechanism; - s/[\r\n].*//s for ($session->{_auth_user}, $session->{_auth_mechanism}); + $session->auth_user($user); + $session->auth_mechanism($mechanism); return OK; } diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 5fd2d87..73493b7 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -37,9 +37,9 @@ sub _register { my $self = shift; my $qp = shift; local $self->{_qp} = $qp; - $self->init($qp, @_); + $self->init($qp, @_) if $self->can('init'); $self->_register_standard_hooks($qp, @_); - $self->register($qp, @_); + $self->register($qp, @_) if $self->can('register'); } # Designed to be overloaded @@ -73,6 +73,14 @@ sub spool_dir { shift->qp->spool_dir; } +sub auth_user { + shift->qp->auth_user(@_); +} + +sub auth_mechanism { + shift->qp->auth_mechanism(@_); +} + sub temp_file { my $self = shift; my $tempfile = $self->qp->temp_file; diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index c9a918c..2753663 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -15,6 +15,8 @@ use fields qw( hooks start_time _auth + _auth_user + _auth_mechanism _commands _config_cache _connection diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index b39373a..d61fcee 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -196,7 +196,9 @@ sub ehlo_respond { $conn->hello_host($hello_host); $self->transaction; - my @capabilities = @{ $self->transaction->notes('capabilities') }; + my @capabilities = $self->transaction->notes('capabilities') + ? @{ $self->transaction->notes('capabilities') } + : (); # Check for possible AUTH mechanisms my %auth_mechanisms; @@ -227,6 +229,19 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { } } +sub auth { + my ( $self, $arg, @stuff ) = @_; + + #they AUTH'd once already + return $self->respond( 503, "but you already said AUTH ..." ) + if ( defined $self->{_auth} + and $self->{_auth} == OK ); + return $self->respond( 503, "AUTH not defined for HELO" ) + if ( $self->connection->hello eq "helo" ); + + return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); +} + sub mail { my $self = shift; return $self->respond(501, "syntax error in parameters") if !$_[0] or $_[0] !~ m/^from:/i; @@ -365,7 +380,6 @@ sub rcpt_respond { return 0; } - sub help { my $self = shift; $self->respond(214, diff --git a/lib/Qpsmtpd/TcpServer.pm b/lib/Qpsmtpd/TcpServer.pm index dcac57d..46022d7 100644 --- a/lib/Qpsmtpd/TcpServer.pm +++ b/lib/Qpsmtpd/TcpServer.pm @@ -39,7 +39,7 @@ sub run { my $self = shift; # should be somewhere in Qpsmtpd.pm and not here... - $self->load_plugins; + $self->load_plugins unless $self->{hooks}; my $rc = $self->start_conversation; return if $rc != DONE; diff --git a/lib/Qpsmtpd/Transaction.pm b/lib/Qpsmtpd/Transaction.pm index 59f7453..6894208 100644 --- a/lib/Qpsmtpd/Transaction.pm +++ b/lib/Qpsmtpd/Transaction.pm @@ -15,9 +15,6 @@ sub start { my %args = @_; my $self = { _notes => { capabilities => [] }, _rcpt => [], started => time }; bless ($self, $class); - my $sz = $self->config('memory_threshold'); - $sz = 10_000 unless defined($sz); - $self->{_size_threshold} = $sz; return $self; } @@ -91,13 +88,28 @@ sub body_current_pos { return $self->{_body_current_pos} || 0; } -# TODO - should we create the file here if we're storing as an array? sub body_filename { my $self = shift; - return unless $self->{_body_file}; + $self->body_spool() unless $self->{_filename}; + $self->{_body_file}->flush(); # so contents won't be cached return $self->{_filename}; } +sub body_spool { + my $self = shift; + $self->log(LOGINFO, "spooling message to disk"); + $self->{_filename} = $self->temp_file(); + $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) + or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; + if ($self->{_body_array}) { + foreach my $line (@{ $self->{_body_array} }) { + $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; + } + $self->{_body_start} = $self->{_header_size}; + } + $self->{_body_array} = undef; +} + sub body_write { my $self = shift; my $data = shift; @@ -125,19 +137,7 @@ sub body_write { $self->{_body_size} += length($1); ++$self->{_body_current_pos}; } - if ($self->{_body_size} >= $self->{_size_threshold}) { - #warn("spooling to disk\n"); - $self->{_filename} = $self->temp_file(); - $self->{_body_file} = IO::File->new($self->{_filename}, O_RDWR|O_CREAT, 0600) - or die "Could not open file $self->{_filename} - $! "; # . $self->{_body_file}->error; - if ($self->{_body_array}) { - foreach my $line (@{ $self->{_body_array} }) { - $self->{_body_file}->print($line) or die "Cannot print to temp file: $!"; - } - $self->{_body_start} = $self->{_header_size}; - } - $self->{_body_array} = undef; - } + $self->body_spool if ( $self->{_body_size} >= $self->size_threshold() ); } } diff --git a/plugins/dnsbl b/plugins/dnsbl index bbd5cd0..5a9a274 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -2,13 +2,18 @@ use Danga::DNS; -sub register { - my ($self) = @_; - $self->register_hook("connect", "connect_handler"); - $self->register_hook("connect", "pickup_handler"); +sub init { + my ($self, $qp, $denial ) = @_; + if ( defined $denial and $denial =~ /^disconnect$/i ) { + $self->{_dnsbl}->{DENY} = DENY_DISCONNECT; + } + else { + $self->{_dnsbl}->{DENY} = DENY; + } + } -sub connect_handler { +sub hook_connect { my ($self, $transaction) = @_; my $remote_ip = $self->connection->remote_ip; @@ -99,8 +104,9 @@ sub process_txt_result { # $qp->finish_continuation if $qp->input_sock->readable; } -sub pickup_handler { - my ($self, $transaction) = @_; +sub hook_rcpt { + my ($self, $transaction, $rcpt) = @_; + my $connection = $self->qp->connection; # RBLSMTPD being non-empty means it contains the failure message to return if (defined ($ENV{'RBLSMTPD'}) && $ENV{'RBLSMTPD'} ne '') { @@ -115,6 +121,14 @@ sub pickup_handler { return DECLINED; } +sub hook_disconnect { + my ($self, $transaction) = @_; + + $self->qp->connection->notes('dnsbl_sockets', undef); + + return DECLINED; +} + 1; =head1 NAME diff --git a/plugins/queue/exim-bsmtp b/plugins/queue/exim-bsmtp new file mode 100644 index 0000000..1258c40 --- /dev/null +++ b/plugins/queue/exim-bsmtp @@ -0,0 +1,138 @@ +=head1 NAME + +exim-bsmtp + +$Id$ + +=head1 DESCRIPTION + +This plugin enqueues mail from qpsmtpd into Exim via BSMTP + +=head1 INSTALLATION + +The qpsmtpd user B be configured in the I setting +in your Exim configuration. If it is not, queueing will still work, +but sender addresses will not be honored by exim, which will make all +mail appear to originate from the smtpd user itself. + +=head1 CONFIGURATION + +The plugin accepts configuration settings in space-delimited name/value +pairs. For example: + + queue/exim-bsmtp exim_path /usr/sbin/exim4 + +=over 4 + +=item exim_path I + +The path to use to execute the Exim BSMTP receiver; by default this is +I. The commandline switch '-bS' will be added (this is +actually redundant with rsmtp, but harmless). + +=cut + +=head1 LICENSE + +Copyright (c) 2004 by Devin Carraway + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +=cut + +use strict; +use warnings; + +use IO::File; +use Sys::Hostname qw(hostname); +use File::Temp qw(tempfile); + +sub register { + my ($self, $qp, %args) = @_; + + $self->{_exim_path} = $args{exim_path} || '/usr/sbin/rsmtp'; + $self->{_exim_path} = $1 if $self->{_exim_path} =~ /(.*)/; + unless (-x $self->{_exim_path}) { + $self->log(LOGERROR, "Could not find exim at $self->{_exim_path};". + " please set exim_path in config/plugins"); + return undef; + } +} + +sub hook_queue { + my ($self, $txn) = @_; + + my $tmp_dir = $self->qp->config('spool_dir') || '/tmp'; + $tmp_dir = $1 if ($tmp_dir =~ /(.*)/); + my ($tmp, $tmpfn) = tempfile("exim-bsmtp.$$.XXXXXX", DIR => $tmp_dir); + unless ($tmp && $tmpfn) { + $self->log(LOGERROR, "Couldn't create tempfile: $!"); + return (DECLINED, 'Internal error enqueueing mail'); + } + + print $tmp "HELO ", hostname(), "\n", + "MAIL FROM:<", ($txn->sender->address || ''), ">\n"; + print $tmp "RCPT TO:<", ($_->address || ''), ">\n" + for $txn->recipients; + print $tmp "DATA\n", + $txn->header->as_string, "\n"; + $txn->body_resetpos; + while (my $line = $txn->body_getline) { + $line =~ s/^\./../; + print $tmp $line; + } + print $tmp ".\nQUIT\n"; + close $tmp; + + my $cmd = "$self->{_exim_path} -bS < $tmpfn"; + $self->log(LOGDEBUG, "executing cmd $cmd"); + my $exim = new IO::File "$cmd|"; + unless ($exim) { + $self->log(LOGERROR, "Could not execute $self->{_exim_path}: $!"); + unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!"); + return (DECLINED, "Internal error enqueuing mail"); + } + # Normally exim produces no output in BSMTP mode; anything that + # does come out is an error worth logging. + my $start = time; + while (<$exim>) { + chomp; + $self->log(LOGERROR, "exim: $_"); + } + $self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)"); + $exim->close; + my $exit = $?; + unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!"); + + $self->log(LOGDEBUG, "Exitcode from exim: $exit"); + if (($exit >> 8) != 0) { + $self->log(LOGERROR, 'BSMTP enqueue failed; exitcode '.($exit >> 8). + " from $self->{_exim_path} -bS"); + return (DECLINED, 'Internal error enqueuing mail'); + } + + $self->log(LOGINFO, "Enqueued to exim via BSMTP"); + return (OK, "Queued!"); +} + + +1; + +# vi: ts=4 sw=4 expandtab syn=perl + diff --git a/plugins/require_resolvable_fromhost b/plugins/require_resolvable_fromhost index a7a498f..acab9e1 100644 --- a/plugins/require_resolvable_fromhost +++ b/plugins/require_resolvable_fromhost @@ -1,22 +1,29 @@ #!/usr/bin/perl - use Danga::DNS; -sub register { - my ($self) = @_; - $self->register_hook("mail", "mail_handler"); - $self->register_hook("rcpt", "rcpt_handler"); +my %invalid = (); + +sub init { + my ($self, $qp) = @_; + foreach my $i ($qp->config("invalid_resolvable_fromhost")) { + $i =~ s/^\s*//; + $i =~ s/\s*$//; + if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) { + $invalid{$1} = $3; + } + } } -sub mail_handler { +sub hook_mail { my ($self, $transaction, $sender) = @_; + return DECLINED + if ($self->qp->connection->notes('whitelistclient')); $self->transaction->notes('resolvable', 1); return DECLINED if $sender->format eq "<>"; return $self->check_dns($sender->host); } - sub check_dns { my ($self, $host) = @_; @@ -66,7 +73,7 @@ sub dns_result { } -sub rcpt_handler { +sub hook_rcpt { my ($self, $transaction) = @_; if (!$transaction->notes('resolvable')) { diff --git a/plugins/rhsbl b/plugins/rhsbl index 96e1dec..5fc3368 100644 --- a/plugins/rhsbl +++ b/plugins/rhsbl @@ -2,14 +2,7 @@ use Danga::DNS; -sub register { - my ($self) = @_; - - $self->register_hook('mail', 'mail_handler'); - $self->register_hook('rcpt', 'rcpt_handler'); -} - -sub mail_handler { +sub hook_mail { my ($self, $transaction, $sender) = @_; my %rhsbl_zones_map = (); @@ -59,7 +52,7 @@ sub process_result { } } -sub rcpt_handler { +sub hook_rcpt { my ($self, $transaction, $rcpt) = @_; my $result = $transaction->notes('rhsbl'); diff --git a/plugins/tls b/plugins/tls index 4d14e19..56a5468 100644 --- a/plugins/tls +++ b/plugins/tls @@ -39,6 +39,7 @@ sub init { SSL_server => 1 ) or die "Could not create SSL context: $!"; + # now extract the password... $self->ssl_context($ssl_ctx); # Check for possible AUTH mechanisms @@ -104,10 +105,18 @@ sub hook_unrecognized_command { my $conn = $self->connection; # Create a new connection object with subset of information collected thus far - my $newconn = Qpsmtpd::Connection->new(); - for (qw(local_ip local_port remote_ip remote_port remote_host remote_info relay_client)) { - $newconn->$_($conn->$_()); - } + my $newconn = Qpsmtpd::Connection->new( + map { $_ => $conn->$_ } + qw( + local_ip + local_port + remote_ip + remote_port + remote_host + remote_info + relay_client + ), + ); $self->qp->connection($newconn); $self->qp->reset_transaction; if ($self->qp->isa('Danga::Socket')) { diff --git a/plugins/virus/clamdscan b/plugins/virus/clamdscan index 569b044..e18bf68 100644 --- a/plugins/virus/clamdscan +++ b/plugins/virus/clamdscan @@ -118,7 +118,7 @@ sub hook_data_post { unless ( $content_type && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) { - $self->log( LOGERROR, "non-multipart mail - skipping" ); + $self->log( LOGNOTICE, "non-multipart mail - skipping" ); return DECLINED; } @@ -153,7 +153,10 @@ sub hook_data_post { $clamd = Clamd->new(); # default unix domain socket } - return (DENYSOFT) unless $clamd->ping(); + unless ( $clamd->ping() ) { + $self->log( LOGERROR, "Cannot ping clamd server - did you provide the correct clamd port or socket?" ); + return DECLINED; + } if ( my %found = $clamd->scan($filename) ) { my $viruses = join( ",", values(%found) ); diff --git a/qpsmtpd b/qpsmtpd index f416f7a..3a1fd34 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -24,9 +24,6 @@ use Getopt::Long; $|++; -# For debugging -# $SIG{USR1} = sub { Carp::confess("USR1") }; - use Socket qw(SOMAXCONN IPPROTO_TCP SO_KEEPALIVE TCP_NODELAY SOL_SOCKET); $SIG{'PIPE'} = "IGNORE"; # handled manually diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index 761e17f..f67b00d 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -39,7 +39,7 @@ usage: qpsmtpd-forkserver [ options ] -u, --user U : run as a particular user (default 'smtpd') -m, --max-from-ip M : limit connections from a single IP; default 5 --pid-file P : print main servers PID to file P - --detach : detach from controlling terminal (daemonize) + -d, --detach : detach from controlling terminal (daemonize) EOT exit 0; } @@ -51,8 +51,8 @@ GetOptions('h|help' => \&usage, 'p|port=i' => \$PORT, 'u|user=s' => \$USER, 'pid-file=s' => \$PID_FILE, - 'd|debug+' => \$DEBUG, - 'detach' => \$DETACH, + 'debug+' => \$DEBUG, + 'd|detach' => \$DETACH, ) || &usage; # detaint the commandline @@ -172,6 +172,10 @@ if ($PID_FILE) { close PID; } +# Populate class cached variables +$qpsmtpd->spool_dir; +$qpsmtpd->size_threshold; + while (1) { REAPER(); my $running = scalar keys %childstatus; @@ -189,7 +193,6 @@ while (1) { # possible something condition... next; } - # Make this client blocking while we figure out if we actually want to # do something with it. IO::Handle::blocking($client, 1); @@ -233,7 +236,17 @@ while (1) { ::log(LOGINFO, "Connection Timed Out"); exit; }; - ::log(LOGINFO, "Accepted connection $running/$MAXCONN"); + my $localsockaddr = getsockname($client); + my ($lport, $laddr) = sockaddr_in($localsockaddr); + $ENV{TCPLOCALIP} = inet_ntoa($laddr); + # my ($port, $iaddr) = sockaddr_in($hisaddr); + $ENV{TCPREMOTEIP} = inet_ntoa($iaddr); + $ENV{TCPREMOTEHOST} = gethostbyaddr($iaddr, AF_INET) || "Unknown"; + + # don't do this! + #$0 = "qpsmtpd-forkserver: $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"; + + ::log(LOGINFO, "Accepted connection $running/$MAXCONN from $ENV{TCPREMOTEIP} / $ENV{TCPREMOTEHOST}"); $::LineMode = 1; @@ -245,11 +258,11 @@ while (1) { $qp->push_back_read("Connect\n"); Qpsmtpd::PollServer->AddTimer(0.1, sub { }); while (1) { - $qp->enable_read; - my $line = $qp->get_line; - last if !defined($line); - my $output = $qp->process_line($line); - $qp->write($output) if $output; + $qp->enable_read; + my $line = $qp->get_line; + last if !defined($line); + my $output = $qp->process_line($line); + $qp->write($output) if $output; } exit; # child leaves diff --git a/t/qpsmtpd-address.t b/t/qpsmtpd-address.t index b041e5a..c08d44b 100644 --- a/t/qpsmtpd-address.t +++ b/t/qpsmtpd-address.t @@ -2,7 +2,7 @@ use strict; $^W = 1; -use Test::More tests => 28; +use Test::More tests => 29; BEGIN { use_ok('Qpsmtpd::Address'); @@ -16,6 +16,11 @@ $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); is ($ao->format, $as, "format $as"); +$as = ''; +$ao = Qpsmtpd::Address->parse($as); +ok ($ao, "parse $as"); +is ($ao->format, $as, "format $as"); + $as = ''; $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); @@ -38,21 +43,6 @@ $ao = Qpsmtpd::Address->parse($as); ok ($ao, "parse $as"); is ($ao->format, '<"foo\ bar"@example.com>', "format $as"); - -$as = 'foo@example.com'; -$ao = Qpsmtpd::Address->parse($as); -is ($ao, undef, "can't parse $as"); - -$as = '<@example.com>'; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - -$as = '<@123>'; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - -$as = ''; -is (Qpsmtpd::Address->parse($as), undef, "can't parse $as"); - - $as = 'foo@example.com'; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); @@ -79,10 +69,35 @@ $as = ''; $ao = Qpsmtpd::Address->new($as); ok ($ao, "new $as"); is ($ao->format, $as, "format $as"); +is ("$ao", $as, "overloaded stringify $as"); $as = 'foo@foo.x.example.com'; ok ($ao = Qpsmtpd::Address->parse("<$as>"), "parse <$as>"); is ($ao && $ao->address, $as, "address $as"); +ok ($ao eq $as, "overloaded 'cmp' operator"); +my @unsorted_list = map { Qpsmtpd::Address->new($_) } + qw( + "musa_ibrah@caramail.comandrea.luger"@wifo.ac.at + foo@example.com + ask@perl.org + foo@foo.x.example.com + jpeacock@cpan.org + test@example.com + ); +# NOTE that this is sorted by _host_ not by _domain_ +my @sorted_list = map { Qpsmtpd::Address->new($_) } + qw( + jpeacock@cpan.org + foo@example.com + test@example.com + foo@foo.x.example.com + ask@perl.org + "musa_ibrah@caramail.comandrea.luger"@wifo.ac.at + ); + +my @test_list = sort @unsorted_list; + +is_deeply( \@test_list, \@sorted_list, "sort via overloaded 'cmp' operator"); From 7cc114edd5bb4a98d159c5f809eefa2cb0626822 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 30 Dec 2005 17:03:14 +0000 Subject: [PATCH 086/106] Eliminate the creeping use of warn() in favor of log() and make more use of the "fd:#" code everywhere. * lib/Qpsmtpd.pm Default log method use '$self->fd()' instead of '$self->{fd}'. Include a sub fd() method for inheritance purposes. * lib/Qpsmtpd/PollServer.pm Inherit log() from Qpsmtpd.pm (via SMTP.pm). * lib/Qpsmtpd/Plugin.pm Appropriate code allow plugins to inherit fd(). * plugins/dnsbl Use log() instead of warn(). * plugins/logging/adaptive plugins/logging/warn Include the 'fd:#' to the log line if defined. * qpsmtpd Reorder things slightly so we can use log(). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@589 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 8 ++++++-- lib/Qpsmtpd/Plugin.pm | 6 +++++- lib/Qpsmtpd/PollServer.pm | 7 ------- plugins/dnsbl | 4 ++-- plugins/logging/adaptive | 2 ++ plugins/logging/warn | 6 ++++-- qpsmtpd | 11 +++++------ 7 files changed, 24 insertions(+), 20 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index a47c4c6..025a761 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -76,7 +76,7 @@ sub varlog { unless ( $rc and $rc == DECLINED or $rc == OK ) { # no logging plugins registered so fall back to STDERR - my $fd = $self->{fd}; + my $fd = $self->fd(); warn join(" ", $$ . (defined $fd ? " fd:$fd" : "") . (defined $plugin ? " $plugin plugin:" : @@ -370,7 +370,7 @@ sub finish_continuation { $r[0] = DECLINED if not defined $r[0]; my $responder = $hook . "_respond"; if (my $meth = $self->can($responder)) { - warn("continuation finished on $self\n"); + $self->log(LOGNOTICE, "continuation finished on $self\n"); return $meth->($self, $r[0], $r[1], @$args); } die "No ${hook}_respond method"; @@ -501,6 +501,10 @@ sub auth_mechanism { return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); } +sub fd { + return shift->{fd}; +} + 1; __END__ diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm index 73493b7..19e9296 100644 --- a/lib/Qpsmtpd/Plugin.pm +++ b/lib/Qpsmtpd/Plugin.pm @@ -50,6 +50,10 @@ sub qp { shift->{_qp}; } +sub fd { + shift->qp->fd(); +} + sub log { my $self = shift; $self->qp->varlog(shift, $self->hook_name, $self->plugin_name, @_) @@ -116,7 +120,7 @@ sub isa_plugin { $self->compile($self->plugin_name . "_isa_$cleanParent", $newPackage, "plugins/$parent"); # assumes Cwd is qpsmtpd root - warn "---- $newPackage\n"; + $self->log(LOGDEBUG,"---- $newPackage\n"); no strict 'refs'; push @{"${currentPackage}::ISA"}, $newPackage; } diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 2753663..266f0f1 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -98,13 +98,6 @@ sub fault { return; } -sub log { - my ($self, $trace, @log) = @_; - my $fd = $self->{fd}; - $fd ||= '?'; - $self->SUPER::log($trace, "fd:$fd", @log); -} - sub process_line { my $self = shift; my $line = shift || return; diff --git a/plugins/dnsbl b/plugins/dnsbl index 5a9a274..cc3ff00 100644 --- a/plugins/dnsbl +++ b/plugins/dnsbl @@ -75,7 +75,7 @@ sub finished { sub process_a_result { my ($qp, $template, $result, $query) = @_; - warn("Result for A $query: $result\n"); + $qp->log(LOGINFO, "Result for A $query: $result\n"); if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) { # NXDOMAIN or ERROR possibly... # $qp->finish_continuation if $qp->input_sock->readable; @@ -92,7 +92,7 @@ sub process_a_result { sub process_txt_result { my ($qp, $result, $query) = @_; - warn("Result for TXT $query: $result\n"); + $qp->log(LOGINFO, "Result for TXT $query: $result\n"); if ($result !~ /[a-z]/) { # NXDOMAIN or ERROR probably... # $qp->finish_continuation if $qp->input_sock->readable; diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 27d0eba..934a4e6 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -44,8 +44,10 @@ sub hook_logging { # wlog return DECLINED if defined $plugin and $plugin eq $self->plugin_name; if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) { + my $fd = $self->fd(); warn join( " ", $$. + (defined $fd ? " fd:$fd" : "") . ( defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" diff --git a/plugins/logging/warn b/plugins/logging/warn index ce25399..ddbf351 100644 --- a/plugins/logging/warn +++ b/plugins/logging/warn @@ -29,11 +29,13 @@ sub hook_logging { # then these lines will not be logged at all. You can safely comment # out this line and it will not cause an infinite loop. return DECLINED if defined $plugin and $plugin eq $self->plugin_name; + my $fd = $self->fd(); warn join(" ", $$ . - (defined $plugin ? " $plugin plugin:" : - defined $hook ? " running plugin ($hook):" : ""), + (defined $fd ? " fd:$fd" : "") . + (defined $plugin ? " $plugin plugin:" : + defined $hook ? " running plugin ($hook):" : ""), @log), "\n" if ($trace <= $self->{_level}); diff --git a/qpsmtpd b/qpsmtpd index 3a1fd34..24b5bfa 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -189,7 +189,6 @@ sub run_as_inetd { my $out = Qpsmtpd::PollServer->new($outsock); $out->load_plugins; - $out->init_logger; $out->input_sock($client); $client->push_back_read("Connect\n"); # Cause poll/kevent/epoll to end quickly in first iteration @@ -241,15 +240,15 @@ sub run_as_server { die "unable to change uid: $!\n"; $> = $quid; - ::log(LOGINFO, 'Running as user '. - (getpwuid($>) || $>) . - ', group '. - (getgrgid($)) || $))); - # Load plugins here my $plugin_loader = Qpsmtpd::SMTP->new(); $plugin_loader->load_plugins; + $plugin_loader->log(LOGINFO, 'Running as user '. + (getpwuid($>) || $>) . + ', group '. + (getgrgid($)) || $))); + if ($PROCS > 1) { $SIG{'CHLD'} = \&sig_chld; my @kids; From 9c8df69be10efc8d818017221107c928230c6d24 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 30 Dec 2005 19:35:10 +0000 Subject: [PATCH 087/106] Fix caching bug with PTR records Attempt to fix callback occurring immediately by calling it via AddTimer git-svn-id: https://svn.perl.org/qpsmtpd/trunk@590 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS/Resolver.pm | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index ce9fb7f..100e234 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -73,9 +73,12 @@ sub _query { $asker->run_callback("NXDNS", $host); return 1; } - if (exists $self->{cache}{$type}{$host}) { + if (exists($self->{cache}{$type}{$host}) && + $self->{cache_timeout}{$type}{$host} >= $now) { # print "CACHE HIT!\n"; - $asker->run_callback($self->{cache}{$type}{$host}, $host); + $self->AddTimer(0, sub { + $asker->run_callback($self->{cache}{$type}{$host}, $host); + }); return 1; } @@ -209,8 +212,11 @@ sub event_read { foreach my $rr ($packet->answer) { if (my $host_method = $type_to_host{$rr->type}) { my $host = $rr->$host_method; - $self->{cache}{$rr->type}{$query} = $host; - $self->{cache_timeout}{$rr->type}{$query} = $now + $rr->ttl; + my $type = $rr->type; + $type = 'A' if $type eq 'PTR'; + # print "DNS Lookup $type $query = $host; TTL = ", $rr->ttl, "\n"; + $self->{cache}{$type}{$query} = $host; + $self->{cache_timeout}{$type}{$query} = $now + $rr->ttl; $qobj->run_callback($host); } elsif ($rr->type eq "MX") { From 9b841dd928ec31f4728e2b50103b686d9c0debdb Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 30 Dec 2005 19:41:06 +0000 Subject: [PATCH 088/106] Add force-poll option (in case your epoll is buggy) Tidy up options Use Pollserver class to load plugins, not unused tcpserver git-svn-id: https://svn.perl.org/qpsmtpd/trunk@591 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd | 1 + 1 file changed, 1 insertion(+) diff --git a/qpsmtpd b/qpsmtpd index 24b5bfa..5ea6a39 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -58,6 +58,7 @@ Options: -j, --procs J : spawn J processes; default 1 -a, --accept K : accept up to K conns per loop; default 20 -h, --help : this page + --use-poll : force use of poll() instead of epoll()/kqueue() NB: -f and -j are mutually exclusive. If -f flag is not used the server uses poll() style loops running inside J child processes. Set J to the number of From abcdd3212c245b37e5226d402e73f0f1d77192c9 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 30 Dec 2005 19:42:57 +0000 Subject: [PATCH 089/106] Tidy up git-svn-id: https://svn.perl.org/qpsmtpd/trunk@592 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index f67b00d..affb829 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -7,7 +7,6 @@ # use lib 'lib'; -use Qpsmtpd::TcpServer; use Qpsmtpd::Constants; use IO::Socket; use IO::Select; @@ -39,22 +38,31 @@ usage: qpsmtpd-forkserver [ options ] -u, --user U : run as a particular user (default 'smtpd') -m, --max-from-ip M : limit connections from a single IP; default 5 --pid-file P : print main servers PID to file P + -h, --help : this page + --use-poll : force use of poll() instead of epoll()/kqueue() -d, --detach : detach from controlling terminal (daemonize) EOT exit 0; } GetOptions('h|help' => \&usage, - 'l|listen-address=s' => \@LOCALADDR, - 'c|limit-connections=i' => \$MAXCONN, - 'm|max-from-ip=i' => \$MAXCONNIP, - 'p|port=i' => \$PORT, - 'u|user=s' => \$USER, - 'pid-file=s' => \$PID_FILE, - 'debug+' => \$DEBUG, - 'd|detach' => \$DETACH, + 'l|listen-address=s' => \@LOCALADDR, + 'c|limit-connections=i' => \$MAXCONN, + 'm|max-from-ip=i' => \$MAXCONNIP, + 'p|port=i' => \$PORT, + 'u|user=s' => \$USER, + 'pid-file=s' => \$PID_FILE, + 'debug+' => \$DEBUG, + 'use-poll' => \&force_poll, + 'h|help' => \&usage, + 'd|detach' => \$DETACH, ) || &usage; +sub force_poll { + $Danga::Socket::HaveEpoll = 0; + $Danga::Socket::HaveKQueue = 0; +} + # detaint the commandline if ($PORT =~ /^(\d+)$/) { $PORT = $1 } else { &usage } @LOCALADDR = ( '0.0.0.0' ) if !@LOCALADDR; @@ -131,7 +139,7 @@ if ($PID_FILE) { } # Load plugins here -my $qpsmtpd = Qpsmtpd::TcpServer->new(); +my $qpsmtpd = Qpsmtpd::PollServer->new(); # Drop privileges my (undef, undef, $quid, $qgid) = getpwnam $USER or From 67a6787625d3ad85f8964d3e2a2421d87d7c9a75 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 30 Dec 2005 19:46:33 +0000 Subject: [PATCH 090/106] Get alarm/timeout from a param git-svn-id: https://svn.perl.org/qpsmtpd/trunk@593 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/PollServer.pm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index 266f0f1..c8a1b17 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -14,6 +14,7 @@ use fields qw( max_size hooks start_time + cmd_timeout _auth _auth_user _auth_mechanism @@ -49,6 +50,7 @@ sub new { $self = fields::new($self) unless ref $self; $self->SUPER::new( @_ ); + $self->{cmd_timeout} = 5; $self->{start_time} = time; $self->{mode} = 'connect'; $self->load_plugins; @@ -106,7 +108,7 @@ sub process_line { my ($pkg, $file, $line) = caller(); die "ALARM: ($self->{mode}) $pkg, $file, $line"; }; - my $prev = alarm(2); # must process a command in < 2 seconds + my $prev = alarm($self->{cmd_timeout}); # must process a command in < N seconds eval { $self->_process_line($line) }; alarm($prev); if ($@) { From 99e0455fa429e9564bdb031f217705c8d9b74ce4 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 30 Dec 2005 19:49:38 +0000 Subject: [PATCH 091/106] Fix long standing bug of returning 1 not DONE git-svn-id: https://svn.perl.org/qpsmtpd/trunk@594 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SMTP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index d61fcee..a61d4e7 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -93,7 +93,7 @@ sub start_conversation { # lib/Qpsmtpd/TcpServer.pm for more confusion. my ($rc, $msg) = $self->run_hooks("connect"); return $self->connect_respond($rc, $msg) unless $rc == CONTINUATION; - return 1; + return DONE; } sub connect_respond { From e440b7bd65f7eb54360791924cd6a65571abaa12 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Fri, 30 Dec 2005 20:03:22 +0000 Subject: [PATCH 092/106] Get forkserver working again git-svn-id: https://svn.perl.org/qpsmtpd/trunk@595 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd-forkserver | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/qpsmtpd-forkserver b/qpsmtpd-forkserver index affb829..6593a56 100755 --- a/qpsmtpd-forkserver +++ b/qpsmtpd-forkserver @@ -45,8 +45,7 @@ EOT exit 0; } -GetOptions('h|help' => \&usage, - 'l|listen-address=s' => \@LOCALADDR, +GetOptions('l|listen-address=s' => \@LOCALADDR, 'c|limit-connections=i' => \$MAXCONN, 'm|max-from-ip=i' => \$MAXCONNIP, 'p|port=i' => \$PORT, @@ -139,7 +138,7 @@ if ($PID_FILE) { } # Load plugins here -my $qpsmtpd = Qpsmtpd::PollServer->new(); +my $qpsmtpd = bless {},'Qpsmtpd'; # ugh - probably should have new() in Qpsmtpd.pm # Drop privileges my (undef, undef, $quid, $qgid) = getpwnam $USER or From 1c2009764f6639362f966011f874ab83568fbf1c Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Sat, 31 Dec 2005 14:53:50 +0000 Subject: [PATCH 093/106] Don't trap $self in the closure (causes circular refs and never gets freed) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@596 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS/Resolver.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 100e234..458fe36 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -76,8 +76,9 @@ sub _query { if (exists($self->{cache}{$type}{$host}) && $self->{cache_timeout}{$type}{$host} >= $now) { # print "CACHE HIT!\n"; + my $result = $self->{cache}{$type}{$host}; $self->AddTimer(0, sub { - $asker->run_callback($self->{cache}{$type}{$host}, $host); + $asker->run_callback($result, $host); }); return 1; } From 7c1c9ef01bc7e4cd1e927d42a7b10ceb913dbbb6 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 5 Jan 2006 02:21:32 +0000 Subject: [PATCH 094/106] Fix problems with tls and relay_client. Merge r597 from branches/0.3x git-svn-id: https://svn.perl.org/qpsmtpd/trunk@598 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Connection.pm | 26 ++++++- plugins/tls | 27 +++----- plugins/tls_cert | 138 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 171 insertions(+), 20 deletions(-) create mode 100755 plugins/tls_cert diff --git a/lib/Qpsmtpd/Connection.pm b/lib/Qpsmtpd/Connection.pm index 8fe3180..8492755 100644 --- a/lib/Qpsmtpd/Connection.pm +++ b/lib/Qpsmtpd/Connection.pm @@ -1,6 +1,20 @@ package Qpsmtpd::Connection; use strict; +# All of these parameters depend only on the physical connection, +# i.e. not on anything sent from the remote machine. Hence, they +# are an appropriate set to use for either start() or clone(). Do +# not add parameters here unless they also meet that criteria. +my @parameters = qw( + remote_host + remote_ip + remote_info + remote_port + local_ip + local_port + relay_client +); + sub new { my $proto = shift; my $class = ref($proto) || $proto; @@ -14,14 +28,22 @@ sub start { my %args = @_; - for my $f (qw(remote_host remote_ip remote_info remote_port - local_ip local_port)) { + foreach my $f ( @parameters ) { $self->$f($args{$f}) if $args{$f}; } return $self; } +sub clone { + my $self = shift; + my $new = $self->new(); + foreach my $f ( @parameters ) { + $new->$f($self->$f()) if $self->$f(); + } + return $new; +} + sub remote_host { my $self = shift; @_ and $self->{_remote_host} = shift; diff --git a/plugins/tls b/plugins/tls index 56a5468..2731449 100644 --- a/plugins/tls +++ b/plugins/tls @@ -25,8 +25,12 @@ use IO::Socket::SSL; # qw(debug1 debug2 debug3 debug4); sub init { my ($self, $qp, $cert, $key) = @_; - $cert ||= 'ssl/cert.pem'; - $key ||= 'ssl/privkey.pem'; + $cert ||= 'ssl/qpsmtpd-server.crt'; + $key ||= 'ssl/qpsmtpd-server.key'; + unless ( -f $cert && -f $key ) { + $self->log(LOGERROR, "Cannot locate cert/key! Run plugins/tls_cert to generate"); + return; + } $self->tls_cert($cert); $self->tls_key($key); @@ -103,21 +107,8 @@ sub hook_unrecognized_command { ) or die "Could not create SSL socket: $!"; } - my $conn = $self->connection; - # Create a new connection object with subset of information collected thus far - my $newconn = Qpsmtpd::Connection->new( - map { $_ => $conn->$_ } - qw( - local_ip - local_port - remote_ip - remote_port - remote_host - remote_info - relay_client - ), - ); - $self->qp->connection($newconn); + # Clone connection object (without data received from client) + $self->qp->connection($self->connection->clone()); $self->qp->reset_transaction; if ($self->qp->isa('Danga::Socket')) { $self->connection->notes('tls_socket', $tlssocket); @@ -134,7 +125,7 @@ sub hook_unrecognized_command { return DENY, "TLS Negotiation Failed"; } - warn("TLS setup returning\n"); + $self->log(LOGWARN, "TLS setup returning"); return DONE; } diff --git a/plugins/tls_cert b/plugins/tls_cert new file mode 100755 index 0000000..51c83d2 --- /dev/null +++ b/plugins/tls_cert @@ -0,0 +1,138 @@ +#!/usr/bin/perl -w +# Very basic script to create TLS certificates for qpsmtpd +use File::Temp qw/ tempfile tempdir /; +use Getopt::Long; + +my %opts = (); +chomp (my $hostname = `hostname --fqdn`); +my %defaults = ( + C => 'XY', + ST => 'unknown', + L => 'unknown', + O => 'QSMTPD', + OU => 'Server', + CN => $hostname, +); + +GetOptions(\%opts, + 'C|Country:s', + 'ST|State:s', + 'L|Locality|City:s', + 'O|Organization:s', + 'OU|OrganizationalUnit|U:s', + 'CN|CommonName|N:s', + 'emailAddress|email|E:s', + 'help|H', +); + +usage() if $opts{help}; + +# initialize defaults +foreach my $key ( keys %defaults ) { + $opts{$key} = $defaults{$key} unless $opts{$key} +} +$opts{emailAddress} = 'postmaster@'.$opts{CN}; + +mkdir('ssl') unless -d 'ssl'; + +my $CA_key = 'ssl/qpsmtpd-ca.key'; +my $CA_crt = 'ssl/qpsmtpd-ca.crt'; +my $CA_serial = 'ssl/.cert.serial'; + +my ($CA, $CAfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1); + +print ${CA} return_cfg('CA'); +close ${CA}; + +system('openssl', 'genrsa', '-out', $CA_key, 2048) == 0 + or die "Cannot create CA key: $?"; + +system('openssl', 'req', '-config', $CAfilename, '-new', '-x509', + '-days', (365*6), '-key', $CA_key, + '-out', $CA_crt) == 0 + or die "Cannot create CA cert: $?"; + +my $SERVER_key = 'ssl/qpsmtpd-server.key'; +my $SERVER_csr = 'ssl/qpsmtpd-server.csr'; +my $SERVER_crt = 'ssl/qpsmtpd-server.crt'; + +my ($SERVER, $SERVERfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1); +print ${SERVER} return_cfg($opts{OU}); +close ${SERVER}; + +system('openssl', 'genrsa', '-out', $SERVER_key, 1024) == 0 + or die "Cannot create server key: $?"; + +system('openssl', 'req', '-config', $SERVERfilename, '-new', + '-key', $SERVER_key, '-out', $SERVER_csr) == 0 + or die "Cannot create CA cert: $?"; + +my ($SIGN, $SIGNfilename) = tempfile( $template, DIR => "ssl", UNLINK => 1); +print ${SIGN} <<"EOT"; +extensions = x509v3 +[ x509v3 ] +subjectAltName = email:copy +nsComment = tls certificate +nsCertType = server +EOT +close ${SIGN}; + +open my $SERIAL, '>', $CA_serial; +print ${SERIAL} "01\n"; +close ${SERIAL}; + +system('openssl', 'x509', '-extfile', $SIGNfilename, '-days', (365*2), + '-CAserial', $CA_serial, '-CA', $CA_crt, + '-CAkey', $CA_key, '-in', $SERVER_csr, + '-req', '-out', $SERVER_crt) == 0 + or die "Cannot sign cert: $?"; + +exit(0); + +sub return_cfg { + my $OU = shift; + my $RANDOM = int(rand(1000)).'RAN'.int(rand(1000)).'DOM'; + my $cfg = <<"EOT"; +[ req ] +default_bits = 1024 +default_keyfile = keyfile.pem +distinguished_name = req_distinguished_name +attributes = req_attributes +prompt = no +output_password = mypass + +[ req_distinguished_name ] +C = $opts{C} +ST = $opts{ST} +L = $opts{L} +O = $opts{O} +OU = $OU +CN = $opts{CN} +emailAddress = $opts{emailAddress} + +[ req_attributes ] +challengePassword = $RANDOM challenge password +EOT + return $cfg; +} + +sub usage { + print STDERR <<"EOT"; + + $0 will generate a TLS certificate "the quick way", + i.e. without interaction. You can change some defaults however. + + These options are recognized: Default: + + --C Country (two letters, e.g. DE) $defaults{C} + --ST State (spelled out) $defaults{ST} + --L City $defaults{L} + --O Organization $defaults{O} + --OU Organizational Unit $defaults{OU} + --CN Common name $defaults{CN} + --email Email address of postmaster postmaster\@CN + --help Show usage + +EOT + exit(1); +} From 48059c122c9588a48a6004338f9482c99921b8c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Wed, 25 Jan 2006 07:12:34 +0000 Subject: [PATCH 095/106] r4215@g5: ask | 2006-01-24 23:11:01 -0800 From: gordonr@gormand.com.au Subject: Re: Submitting plugins (was Re: New plugin: denybounce) Date: January 24, 2006 9:02:35 PM PST To: ask@develooper.com Cc: gavin@openfusion.com.au, qpsmtpd@perl.org Message-Id: <43D7066B.3050106@gormand.com.au> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Ask Bjørn Hansen wrote: On Jan 24, 2006, at 1:08 PM, Gordon Rowell wrote: - License statement - either as per qpsmtpd or as per Perl or similar open license No, it really should be MIT licensed ("as per qpsmtpd") to go in the distribution. There are a few exceptions (only your plugins at a cursory glance), but those are mistakes. :-) I don't have an issue with my qpsmtpd plugins being changed to state: =head1 AUTHOR Copyright 2005 Gordon Rowell This software is free software and may be distributed under the same terms as qpsmtpd itself. Though as a distro maintainer, we do have a sizeable issue with license proliferation. It really is a bit of a nightmare when two licenses are almost, but not completely, the same. Thanks, Gordon r4216@g5: ask | 2006-01-24 23:12:21 -0800 merge license fix from trunk git-svn-id: https://svn.perl.org/qpsmtpd/trunk@603 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/auth/auth_cvm_unix_local | 4 ++-- plugins/check_badrcptto_patterns | 4 ++-- plugins/check_norelay | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/auth/auth_cvm_unix_local b/plugins/auth/auth_cvm_unix_local index dc4c7b7..4c9f460 100644 --- a/plugins/auth/auth_cvm_unix_local +++ b/plugins/auth/auth_cvm_unix_local @@ -31,8 +31,8 @@ Credential Validation Module (http://untroubled.org/cvm). Copyright 2005 Gordon Rowell -This software is free software and may be distributed or modified -under the same terms as Perl itself. +This software is free software and may be distributed under the same +terms as qpsmtpd itself. =head1 VERSION diff --git a/plugins/check_badrcptto_patterns b/plugins/check_badrcptto_patterns index 7b82945..c551bab 100644 --- a/plugins/check_badrcptto_patterns +++ b/plugins/check_badrcptto_patterns @@ -21,8 +21,8 @@ to the left and right of the @. Copyright 2005 Gordon Rowell -This software is free software and may be distributed under the same -terms as Perl itself. +This software is free software and may be distributed under the same +terms as qpsmtpd itself. =cut diff --git a/plugins/check_norelay b/plugins/check_norelay index 8c99aa2..08e37c3 100644 --- a/plugins/check_norelay +++ b/plugins/check_norelay @@ -30,7 +30,7 @@ Based on check_relay plugin from the qpsmtpd distribution. Copyright 2005 Gordon Rowell This software is free software and may be distributed under the same -terms as Perl itself. +terms as qpsmtpd itself. =cut From 654179e8c835deba2f2f64b963eb0216703d0113 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 26 Jan 2006 21:31:05 +0000 Subject: [PATCH 096/106] Working AUTH support in PollServer mode. All AUTH code moved to SMTP.pm (the Auth.pm POD will get renamed to README.authentication). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@605 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd.pm | 20 +++-- lib/Qpsmtpd/Auth.pm | 115 -------------------------- lib/Qpsmtpd/Constants.pm | 1 + lib/Qpsmtpd/PollServer.pm | 10 ++- lib/Qpsmtpd/SMTP.pm | 168 ++++++++++++++++++++++++++++++++++---- 5 files changed, 176 insertions(+), 138 deletions(-) diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index 025a761..dc01b48 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -487,20 +487,30 @@ sub size_threshold { return $Size_threshold; } +sub authenticated { + my ($self, $state) = @_; + $self->{_auth_state} = $state if $state; + return (defined $self->{_auth_state} ? $self->{_auth_state} : 0); +} + sub auth_user { my ($self, $user) = @_; - $user =~ s/[\r\n].*//s; - $self->{_auth_user} = $user if $user; + $self->{_auth_user} = $user if $user; return (defined $self->{_auth_user} ? $self->{_auth_user} : "" ); } +sub auth_ticket { + my ($self, $ticket) = @_; + $self->{_auth_ticket} = $ticket if $ticket; + return (defined $self->{_auth_ticket} ? $self->{_auth_ticket} : "" ); +} + sub auth_mechanism { my ($self, $mechanism) = @_; - $mechanism =~ s/[\r\n].*//s; - $self->{_auth_mechanism} = $mechanism if $mechanism; + $self->{_auth_mechanism} = lc($mechanism) if $mechanism; return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "" ); } - + sub fd { return shift->{fd}; } diff --git a/lib/Qpsmtpd/Auth.pm b/lib/Qpsmtpd/Auth.pm index ada6173..e5ed01a 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/lib/Qpsmtpd/Auth.pm @@ -214,119 +214,4 @@ Please see the LICENSE file included with qpsmtpd for details. =cut -package Qpsmtpd::Auth; -use Qpsmtpd::Constants; -use MIME::Base64; - -sub e64 -{ - my ($arg) = @_; - my $res = encode_base64($arg); - chomp($res); - return($res); -} - -sub SASL { - - # $DB::single = 1; - my ( $session, $mechanism, $prekey ) = @_; - my ( $user, $passClear, $passHash, $ticket ); - $mechanism = lc($mechanism); - - if ( $mechanism eq "plain" ) { - if (!$prekey) { - $session->respond( 334, "Please continue" ); - $prekey= <>; - } - ( $passHash, $user, $passClear ) = split /\x0/, - decode_base64($prekey); - - } - elsif ($mechanism eq "login") { - - if ( $prekey ) { - ($passHash, $user, $passClear) = split /\x0/, decode_base64($prekey); - } - else { - - $session->respond(334, e64("Username:")); - $user = decode_base64(<>); - #warn("Debug: User: '$user'"); - if ($user eq '*') { - $session->respond(501, "Authentification canceled"); - return DECLINED; - } - - $session->respond(334, e64("Password:")); - $passClear = <>; - $passClear = decode_base64($passClear); - #warn("Debug: Pass: '$pass'"); - if ($passClear eq '*') { - $session->respond(501, "Authentification canceled"); - return DECLINED; - } - } - } - elsif ( $mechanism eq "cram-md5" ) { - - # rand() is not cryptographic, but we only need to generate a globally - # unique number. The rand() is there in case the user logs in more than - # once in the same second, of if the clock is skewed. - $ticket = sprintf( "<%x.%x\@" . $session->config("me") . ">", - rand(1000000), time() ); - - # We send the ticket encoded in Base64 - $session->respond( 334, encode_base64( $ticket, "" ) ); - my $line = <>; - chop($line); - chop($line); - - if ( $line eq '*' ) { - $session->respond( 501, "Authentification canceled" ); - return DECLINED; - } - - ( $user, $passHash ) = split( ' ', decode_base64($line) ); - - } - else { - $session->respond( 500, "Unrecognized authentification mechanism" ); - return DECLINED; - } - - # try running the specific hooks first - my ( $rc, $msg ) = - $session->run_hooks( "auth-$mechanism", $mechanism, $user, $passClear, - $passHash, $ticket ); - - # try running the polymorphous hooks next - if ( !$rc || $rc == DECLINED ) { - ( $rc, $msg ) = - $session->run_hooks( "auth", $mechanism, $user, $passClear, - $passHash, $ticket ); - } - - if ( $rc == OK ) { - $msg = "Authentication successful for $user" . - ( defined $msg ? " - " . $msg : "" ); - $session->respond( 235, $msg ); - $session->connection->relay_client(1); - $session->log( LOGINFO, $msg ); - - $session->auth_user($user); - $session->auth_mechanism($mechanism); - - return OK; - } - else { - $msg = "Authentication failed for $user" . - ( defined $msg ? " - " . $msg : "" ); - $session->respond( 535, $msg ); - $session->log( LOGERROR, $msg ); - return DENY; - } -} - -# tag: qpsmtpd plugin that sets RELAYCLIENT when the user authentifies - 1; diff --git a/lib/Qpsmtpd/Constants.pm b/lib/Qpsmtpd/Constants.pm index 8be3268..27bebf0 100644 --- a/lib/Qpsmtpd/Constants.pm +++ b/lib/Qpsmtpd/Constants.pm @@ -26,6 +26,7 @@ my %return_codes = ( DECLINED => 909, DONE => 910, CONTINUATION => 911, + AUTH_PENDING => 912, ); use vars qw(@ISA @EXPORT); diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index c8a1b17..a6db0d4 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -15,9 +15,10 @@ use fields qw( hooks start_time cmd_timeout - _auth - _auth_user _auth_mechanism + _auth_state + _auth_ticket + _auth_user _commands _config_cache _connection @@ -158,6 +159,9 @@ sub process_cmd { } return $resp; } + elsif ( $self->authenticated == AUTH_PENDING ) { + return $self->auth_process($line); + } else { # No such method - i.e. unrecognized command my ($rc, $msg) = $self->run_hooks("unrecognized_command", $meth, @params); @@ -315,7 +319,7 @@ sub end_of_data { } # only true if client authenticated - if ( defined $self->{_auth} and $self->{_auth} == OK ) { + if ( $self->authenticated == OK ) { $header->add("X-Qpsmtpd-Auth","True"); } diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index a61d4e7..87f0118 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -12,6 +12,7 @@ use Qpsmtpd::Auth; use Qpsmtpd::Address (); use Mail::Header (); +use MIME::Base64; #use Data::Dumper; use POSIX qw(strftime); use Net::DNS; @@ -48,6 +49,11 @@ sub dispatch { $self->{_counter}++; + if ( $self->authenticated == AUTH_PENDING ) { + # must be in the middle of prompting for auth parameters + return $self->auth_process($cmd,@_); + } + if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1}) { my ($rc, $msg) = $self->run_hooks("unrecognized_command", $cmd, @_); return $self->unrecognized_command_respond($rc, $msg, @_) unless $rc == CONTINUATION; @@ -114,13 +120,13 @@ sub connect_respond { elsif ($rc != DONE) { my $greets = $self->config('smtpgreeting'); if ( $greets ) { - $greets .= " ESMTP"; + $greets .= " ESMTP"; } else { - $greets = $self->config('me') - . " ESMTP qpsmtpd " - . $self->version - . " ready; send us your mail, but not your spam."; + $greets = $self->config('me') + . " ESMTP qpsmtpd " + . $self->version + . " ready; send us your mail, but not your spam."; } $self->respond(220, $greets); @@ -197,8 +203,8 @@ sub ehlo_respond { $self->transaction; my @capabilities = $self->transaction->notes('capabilities') - ? @{ $self->transaction->notes('capabilities') } - : (); + ? @{ $self->transaction->notes('capabilities') } + : (); # Check for possible AUTH mechanisms my %auth_mechanisms; @@ -229,17 +235,148 @@ HOOK: foreach my $hook ( keys %{$self->{hooks}} ) { } } +sub e64 +{ + my ($arg) = @_; + my $res = encode_base64($arg); + chomp($res); + return($res); +} + sub auth { - my ( $self, $arg, @stuff ) = @_; + my ( $self, $mechanism, $prekey ) = @_; #they AUTH'd once already return $self->respond( 503, "but you already said AUTH ..." ) - if ( defined $self->{_auth} - and $self->{_auth} == OK ); + if ( $self->authenticated == OK ); return $self->respond( 503, "AUTH not defined for HELO" ) if ( $self->connection->hello eq "helo" ); - return $self->{_auth} = Qpsmtpd::Auth::SASL( $self, $arg, @stuff ); + # $DB::single = 1; + + $self->auth_mechanism($mechanism); + $self->authenticated(AUTH_PENDING); + if ( $prekey ) { # easy single step + unless ( $mechanism =~ /^(plain|login)$/i ) { + # must be plain or login + $self->respond( 500, "Unrecognized authentification mechanism" ); + return DECLINED; + } + my ($passHash, $user, $passClear) = split /\x0/,decode_base64($prekey); + # we have all of the elements ready to go now + if ( $mechanism =~ /login/i ) { + $self->auth_user($user); + return $self->auth_process(e64($passClear)); + } + else { + return $self->auth_process($prekey); + } + } + else { + if ( $mechanism =~ /plain/i ) { + $self->respond( 334, "Please continue" ); + } + elsif ( $mechanism =~ /login/i ) { + $self->respond( 334, e64("Username:") ); + } + elsif ( $mechanism =~ /cram-md5/i ) { + # rand() is not cryptographic, but we only need to generate a globally + # unique number. The rand() is there in case the user logs in more than + # once in the same second, or if the clock is skewed. + my $ticket = sprintf( "<%x.%x\@" . $self->config("me") . ">", + rand(1000000), time() ); + + # Store this for later + $self->auth_ticket($ticket); + # We send the ticket encoded in Base64 + $self->respond( 334, encode_base64( $ticket, "" ) ); + } + } + return DECLINED; +} + +sub auth_process { + my ($self, $line) = @_; + my ( $user, $passClear, $passHash, $ticket, $mechanism ); + + # do this once here + $mechanism = $self->auth_mechanism; + $user = $self->auth_user; + $ticket = $self->auth_ticket; + + if ( $mechanism eq 'plain' ) { + ( $passHash, $user, $passClear ) = split /\x0/, + decode_base64($line); + } + elsif ( $mechanism eq 'login' ) { + if ( $user ) { + # must be getting the password now + $passClear = decode_base64($line); + } + else { + # must be getting the user now + $user = decode_base64($line); + $self->auth_user($user); + $self->respond(334, e64("Password:")); + } + } + elsif ( $mechanism eq "cram-md5" ) { + $line =~ tr/[\r\n]//d; # cannot simply chomp CRLF + + ( $user, $passHash ) = split( ' ', decode_base64($line) ); + + } + else { + $self->respond( 500, "Unrecognized authentification mechanism" ); + return DECLINED; + } + if ($user eq '*') { + $self->respond(501, "Authentification canceled"); + return DECLINED; + } + + # check to see if we can proceed with the hooks + if ( $user and ( $passClear or $passHash ) ) { + # try running the specific hooks first + my ( $rc, $msg ) = + $self->run_hooks( "auth-$mechanism", + $mechanism, $user, $passClear, + $passHash, $ticket ); + + # try running the polymorphous hooks next + if ( !$rc || $rc == DECLINED ) { + ( $rc, $msg ) = + $self->run_hooks( "auth", $mechanism, $user, $passClear, + $passHash, $ticket ); + } + return $self->auth_respond($rc, $msg, $mechanism, $user) + unless $rc == CONTINUATION; + } + else { + return CONTINUATION; + } +} + + +sub auth_respond { + my ($self, $rc, $msg, $mechanism, $user) = @_; + if ( $rc == OK ) { + $msg = "Authentication successful for $user" . + ( defined $msg ? " - " . $msg : "" ); + $self->respond( 235, $msg ); + $self->connection->relay_client(1); + $self->log( LOGINFO, $msg ); + $self->authenticated(OK); + + return OK; + } + else { + $msg = "Authentication failed for $user" . + ( defined $msg ? " - " . $msg : "" ); + $self->respond( 535, $msg ); + $self->log( LOGERROR, $msg ); + return DENY; + } } sub mail { @@ -541,8 +678,8 @@ sub data_respond { # FIXME - call plugins to work on just the header here; can # save us buffering the mail content. - # Save the start of just the body itself - $self->transaction->set_body_start(); + # Save the start of just the body itself + $self->transaction->set_body_start(); } @@ -564,8 +701,9 @@ sub data_respond { $self->transaction->header($header); my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; - my $authheader = (defined $self->{_auth} and $self->{_auth} == OK) ? - "(smtp-auth username $self->{_auth_user}, mechanism $self->{_auth_mechanism})\n" : ""; + my $authheader = ($self->authenticated == OK) + ? "(smtp-auth username $self->auth_user, mechanism $self->auth_mechanism)\n" + : ""; $header->add("Received", "from ".$self->connection->remote_info ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip From 29d739b009d40aa14157f5b5fa3bbd23a18c8780 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Thu, 26 Jan 2006 21:36:34 +0000 Subject: [PATCH 097/106] Rename Qpsmtpd::Auth to README.authentication. Replace tabs with spaces in a few plugins. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@606 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Auth.pm => README.authentication | 16 ++++++++-------- plugins/logging/adaptive | 4 ++-- plugins/logging/warn | 4 ++-- plugins/stats | 11 ++--------- 4 files changed, 14 insertions(+), 21 deletions(-) rename lib/Qpsmtpd/Auth.pm => README.authentication (96%) diff --git a/lib/Qpsmtpd/Auth.pm b/README.authentication similarity index 96% rename from lib/Qpsmtpd/Auth.pm rename to README.authentication index e5ed01a..d2cf056 100644 --- a/lib/Qpsmtpd/Auth.pm +++ b/README.authentication @@ -1,8 +1,10 @@ -#!/usr/bin/perl -w +# +# read this with 'perldoc README.authentication' ... +# =head1 NAME -Qpsmtpd::Auth - Authentication framework for qpsmtpd +Authentication framework for qpsmtpd =head1 DESCRIPTION @@ -15,7 +17,7 @@ for more details. =head1 USAGE -This module is automatically loaded by Qpsmtpd::SMTP only if a plugin +This code is automatically loaded by Qpsmtpd::SMTP only if a plugin providing one of the defined L is loaded. The only time this can happen is if the client process employs the EHLO command to initiate the SMTP session. If the client uses HELO, the AUTH command is @@ -30,14 +32,14 @@ All plugins must provide two functions: =over 4 -=item * register() +=item * init() This is the standard function which is called by qpsmtpd for any plugin listed in config/plugins. Typically, an auth plugin should register at least one hook, like this: - sub register { + sub init { my ($self, $qp) = @_; $self->register_hook("auth", "authfunction"); @@ -205,7 +207,7 @@ John Peacock =head1 COPYRIGHT AND LICENSE -Copyright (c) 2004 John Peacock +Copyright (c) 2004-2006 John Peacock Portions based on original code by Ask Bjoern Hansen and Guillaume Filion @@ -213,5 +215,3 @@ This plugin is licensed under the same terms as the qpsmtpd package itself. Please see the LICENSE file included with qpsmtpd for details. =cut - -1; diff --git a/plugins/logging/adaptive b/plugins/logging/adaptive index 934a4e6..76f0f26 100644 --- a/plugins/logging/adaptive +++ b/plugins/logging/adaptive @@ -44,10 +44,10 @@ sub hook_logging { # wlog return DECLINED if defined $plugin and $plugin eq $self->plugin_name; if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) { - my $fd = $self->fd(); + my $fd = $self->fd(); warn join( " ", $$. - (defined $fd ? " fd:$fd" : "") . + (defined $fd ? " fd:$fd" : "") . ( defined $plugin ? " $plugin plugin:" : defined $hook ? " running plugin ($hook):" diff --git a/plugins/logging/warn b/plugins/logging/warn index ddbf351..2308b74 100644 --- a/plugins/logging/warn +++ b/plugins/logging/warn @@ -10,10 +10,10 @@ sub register { $self->{_level} = LOGWARN; if ( defined($loglevel) ) { if ($loglevel =~ /^\d+$/) { - $self->{_level} = $loglevel; + $self->{_level} = $loglevel; } else { - $self->{_level} = log_level($loglevel); + $self->{_level} = log_level($loglevel); } } diff --git a/plugins/stats b/plugins/stats index fbe0119..43c6e37 100644 --- a/plugins/stats +++ b/plugins/stats @@ -7,13 +7,6 @@ our $MAILS_RECEIVED = 0; our $MAILS_REJECTED = 0; our $MAILS_TEMPFAIL = 0; -sub register { - my ($self) = @_; - - $self->register_hook('deny', 'increment_deny'); - $self->register_hook('queue', 'increment_mails'); -} - sub get_stats { my $class = shift; my $uptime = $class->uptime; @@ -29,7 +22,7 @@ sub get_stats { $uptime, $recvd, $reject, $soft, $rate); } -sub increment_deny { +sub hook_deny { my ($self, $tran, $plugin, $level) = @_; if ($level == DENY or $level == DENY_DISCONNECT) { @@ -42,7 +35,7 @@ sub increment_deny { return DECLINED; } -sub increment_mails { +sub hook_mail { my $self = shift; $MAILS_RECEIVED++; From 347e5d328ffd3e4a236cd30bb6a7bbd5ced000b3 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 27 Jan 2006 17:16:13 +0000 Subject: [PATCH 098/106] Oops, forgot to remove all traces of Qmsptmd::Auth while I was at it. Also made auth_vpopmail_sql be quieter about problems authenticating. git-svn-id: https://svn.perl.org/qpsmtpd/trunk@607 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/PollServer.pm | 1 - lib/Qpsmtpd/SMTP.pm | 1 - plugins/auth/auth_vpopmail_sql | 5 +++-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/Qpsmtpd/PollServer.pm b/lib/Qpsmtpd/PollServer.pm index a6db0d4..afa1ec0 100644 --- a/lib/Qpsmtpd/PollServer.pm +++ b/lib/Qpsmtpd/PollServer.pm @@ -28,7 +28,6 @@ use fields qw( _continuation ); use Qpsmtpd::Constants; -use Qpsmtpd::Auth; use Qpsmtpd::Address; use Danga::DNS; use Mail::Header; diff --git a/lib/Qpsmtpd/SMTP.pm b/lib/Qpsmtpd/SMTP.pm index 87f0118..ec29377 100644 --- a/lib/Qpsmtpd/SMTP.pm +++ b/lib/Qpsmtpd/SMTP.pm @@ -8,7 +8,6 @@ use Carp; use Qpsmtpd::Plugin; use Qpsmtpd::Constants; -use Qpsmtpd::Auth; use Qpsmtpd::Address (); use Mail::Header (); diff --git a/plugins/auth/auth_vpopmail_sql b/plugins/auth/auth_vpopmail_sql index 8f07479..81de033 100644 --- a/plugins/auth/auth_vpopmail_sql +++ b/plugins/auth/auth_vpopmail_sql @@ -67,8 +67,9 @@ sub authsql { my $dbuser = "vpopmailuser"; my $dbpasswd = "**********"; - my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd ); - $dbh->{ShowErrorStatement} = 1; + my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd, + { PrintError => 0, } ) + or return DECLINED; my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_; From 7b564e45482aa4910aac7d6bc8c7133d7130e9e6 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Fri, 27 Jan 2006 21:13:43 +0000 Subject: [PATCH 099/106] Make DBI->connect() failure more obvious, but don't prevent mail being sent by other rules (if the client will fall back). git-svn-id: https://svn.perl.org/qpsmtpd/trunk@608 958fd67b-6ff1-0310-b445-bb7760255be9 --- plugins/auth/auth_vpopmail_sql | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/plugins/auth/auth_vpopmail_sql b/plugins/auth/auth_vpopmail_sql index 81de033..344433a 100644 --- a/plugins/auth/auth_vpopmail_sql +++ b/plugins/auth/auth_vpopmail_sql @@ -60,7 +60,8 @@ sub authsql { use DBI; use Qpsmtpd::Constants; use Digest::HMAC_MD5 qw(hmac_md5_hex); - + my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) + = @_; # $DB::single = 1; my $connect = "dbi:mysql:dbname=vpopmail"; @@ -69,10 +70,11 @@ sub authsql { my $dbh = DBI->connect( $connect, $dbuser, $dbpasswd, { PrintError => 0, } ) - or return DECLINED; + or ( + $self->log(LOGERROR, $DBI::errstr) + and return DECLINED + ); - my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = - @_; my ( $pw_name, $pw_domain ) = split "@", lc($user); unless ( defined $pw_domain ) { From a8c4a3c5e1cb9a62b4a6830bf3f99ef834001522 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Fri, 17 Feb 2006 19:04:52 +0000 Subject: [PATCH 100/106] r4448@g5: ask | 2006-02-17 11:04:44 -0800 update license year git-svn-id: https://svn.perl.org/qpsmtpd/trunk@616 958fd67b-6ff1-0310-b445-bb7760255be9 --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index 7856ad1..cc7a68a 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (C) 2001-2005 Ask Bjoern Hansen, Develooper LLC +Copyright (C) 2001-2006 Ask Bjoern Hansen, Develooper LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in From f31d18c6cd1aa8c55f5fedda9a201a6cc96e0d6a Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 20 Jun 2006 13:51:32 +0000 Subject: [PATCH 101/106] Simplify qpsmtpd script (remove inetd and forking server) Greatly simplify Danga::Client due to no more need for line mode client Update to latest Danga::Socket Fix check_earlytalker to use new API Fix Danga::DNS to use new API git-svn-id: https://svn.perl.org/qpsmtpd/trunk@643 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Client.pm | 104 +--- lib/Danga/DNS.pm | 10 +- lib/Danga/Socket.pm | 1008 +++++++++++++++++++++++-------------- lib/Qpsmtpd.pm | 6 +- plugins/check_earlytalker | 39 +- qpsmtpd | 150 +----- 6 files changed, 725 insertions(+), 592 deletions(-) diff --git a/lib/Danga/Client.pm b/lib/Danga/Client.pm index c1ceabd..373f12d 100644 --- a/lib/Danga/Client.pm +++ b/lib/Danga/Client.pm @@ -2,7 +2,7 @@ package Danga::Client; use base 'Danga::TimeoutSocket'; -use fields qw(line closing disable_read can_read_mode); +use fields qw(line pause_count); use Time::HiRes (); # 30 seconds max timeout! @@ -21,68 +21,14 @@ sub new { sub reset_for_next_message { my Danga::Client $self = shift; $self->{line} = ''; - $self->{disable_read} = 0; - $self->{can_read_mode} = 0; + $self->{pause_count} = 0; return $self; } -sub get_line { - my Danga::Client $self = shift; - if (!$self->have_line) { - $self->SetPostLoopCallback(sub { $self->have_line ? 0 : 1 }); - #warn("get_line PRE\n"); - $self->EventLoop(); - #warn("get_line POST\n"); - $self->disable_read(); - } - return if $self->{closing}; - # now have a line. - $self->{alive_time} = time; - $self->{line} =~ s/^(.*?\n)//; - return $1; -} - -sub can_read { - my Danga::Client $self = shift; - my ($timeout) = @_; - my $end = Time::HiRes::time() + $timeout; - # warn("Calling can-read\n"); - $self->{can_read_mode} = 1; - if (!length($self->{line})) { - $self->disable_read(); - # loop because any callback, not just ours, can make EventLoop return - while( !(length($self->{line}) || (Time::HiRes::time > $end)) ) { - $self->SetPostLoopCallback(sub { (length($self->{line}) || - (Time::HiRes::time > $end)) ? 0 : 1 }); - #warn("get_line PRE\n"); - $self->EventLoop(); - #warn("get_line POST\n"); - } - $self->enable_read(); - } - $self->{can_read_mode} = 0; - $self->SetPostLoopCallback(undef); - return if $self->{closing}; - $self->{alive_time} = time; - # warn("can_read returning for '$self->{line}'\n"); - return 1 if length($self->{line}); - return; -} - -sub have_line { - my Danga::Client $self = shift; - return 1 if $self->{closing}; - if ($self->{line} =~ /\n/) { - return 1; - } - return 0; -} - sub event_read { my Danga::Client $self = shift; my $bref = $self->read(8192); return $self->close($!) unless defined $bref; - # $self->watch_read(0); $self->process_read_buf($bref); } @@ -90,8 +36,7 @@ sub process_read_buf { my Danga::Client $self = shift; my $bref = shift; $self->{line} .= $$bref; - return if ! $self->readable(); - return if $::LineMode; + return if $self->paused(); while ($self->{line} =~ s/^(.*?\n)//) { my $line = $1; @@ -99,34 +44,40 @@ sub process_read_buf { my $resp = $self->process_line($line); if ($::DEBUG > 1 and $resp) { print "$$:".($self+0)."S: $_\n" for split(/\n/, $resp) } $self->write($resp) if $resp; - $self->watch_read(0) if $self->{disable_read}; - last if ! $self->readable(); - } - if($self->have_line) { - $self->shift_back_read($self->{line}); - $self->{line} = ''; + # $self->watch_read(0) if $self->{pause_count}; + last if $self->paused(); } } -sub readable { +sub has_data { my Danga::Client $self = shift; - return 0 if $self->{disable_read} > 0; - return 0 if $self->{closed} > 0; - return 1; + return length($self->{line}) ? 1 : 0; } -sub disable_read { +sub clear_data { my Danga::Client $self = shift; - $self->{disable_read}++; - $self->watch_read(0); + $self->{line} = ''; } -sub enable_read { +sub paused { my Danga::Client $self = shift; - $self->{disable_read}--; - if ($self->{disable_read} <= 0) { - $self->{disable_read} = 0; - $self->watch_read(1); + return 1 if $self->{pause_count}; + return 1 if $self->{closed}; + return 0; +} + +sub pause_read { + my Danga::Client $self = shift; + $self->{pause_count}++; + # $self->watch_read(0); +} + +sub continue_read { + my Danga::Client $self = shift; + $self->{pause_count}--; + if ($self->{pause_count} <= 0) { + $self->{pause_count} = 0; + # $self->watch_read(1); } } @@ -137,7 +88,6 @@ sub process_line { sub close { my Danga::Client $self = shift; - $self->{closing} = 1; print "closing @_\n" if $::DEBUG; $self->SUPER::close(@_); } diff --git a/lib/Danga/DNS.pm b/lib/Danga/DNS.pm index 8b76bdd..4dbbf15 100644 --- a/lib/Danga/DNS.pm +++ b/lib/Danga/DNS.pm @@ -25,7 +25,7 @@ sub new { $resolver ||= Danga::DNS::Resolver->new(); my $client = $options{client}; - $client->disable_read if $client; + $client->pause_read() if $client; $self = fields::new($self) unless ref $self; @@ -40,13 +40,13 @@ sub new { if ($options{type}) { if ( ($options{type} eq 'A') || ($options{type} eq 'PTR') ) { if (!$resolver->query($self, @{$self->{hosts}})) { - $client->enable_read() if $client; + $client->continue_read() if $client; return; } } else { if (!$resolver->query_type($self, $options{type}, @{$self->{hosts}})) { - $client->enable_read() if $client; + $client->continue_read() if $client; return; } # die "Unsupported DNS query type: $options{type}"; @@ -54,7 +54,7 @@ sub new { } else { if (!$resolver->query($self, @{$self->{hosts}})) { - $client->enable_read() if $client; + $client->continue_read() if $client; return; } } @@ -84,7 +84,7 @@ sub DESTROY { $self->{callback}->("NXDOMAIN", $host); } } - $self->{client}->enable_read if $self->{client}; + $self->{client}->continue_read() if $self->{client}; if ($self->{finished}) { $self->{finished}->(); } diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm index 5ffac3d..69cf219 100644 --- a/lib/Danga/Socket.pm +++ b/lib/Danga/Socket.pm @@ -2,16 +2,100 @@ =head1 NAME -Danga::Socket - Event-driven async IO class +Danga::Socket - Event loop and event-driven async socket base class =head1 SYNOPSIS + package My::Socket + use Danga::Socket; use base ('Danga::Socket'); + use fields ('my_attribute'); + + sub new { + my My::Socket $self = shift; + $self = fields::new($self) unless ref $self; + $self->SUPER::new( @_ ); + + $self->{my_attribute} = 1234; + return $self; + } + + sub event_err { ... } + sub event_hup { ... } + sub event_write { ... } + sub event_read { ... } + sub close { ... } + + $my_sock->tcp_cork($bool); + + # write returns 1 if all writes have gone through, or 0 if there + # are writes in queue + $my_sock->write($scalar); + $my_sock->write($scalarref); + $my_sock->write(sub { ... }); # run when previous data written + $my_sock->write(undef); # kick-starts + + # read max $bytecount bytes, or undef on connection closed + $scalar_ref = $my_sock->read($bytecount); + + # watch for writability. not needed with ->write(). write() + # will automatically turn on watch_write when you wrote too much + # and turn it off when done + $my_sock->watch_write($bool); + + # watch for readability + $my_sock->watch_read($bool); + + # if you read too much and want to push some back on + # readable queue. (not incredibly well-tested) + $my_sock->push_back_read($buf); # scalar or scalar ref + + Danga::Socket->AddOtherFds(..); + Danga::Socket->SetLoopTimeout($millisecs); + Danga::Socket->DescriptorMap(); + Danga::Socket->WatchedSockets(); # count of DescriptorMap keys + Danga::Socket->SetPostLoopCallback($code); + Danga::Socket->EventLoop(); =head1 DESCRIPTION -This is an abstract base class which provides the basic framework for -event-driven asynchronous IO. +This is an abstract base class for objects backed by a socket which +provides the basic framework for event-driven asynchronous IO, +designed to be fast. Danga::Socket is both a base class for objects, +and an event loop. + +Callers subclass Danga::Socket. Danga::Socket's constructor registers +itself with the Danga::Socket event loop, and invokes callbacks on the +object for readability, writability, errors, and other conditions. + +Because Danga::Socket uses the "fields" module, your subclasses must +too. + +=head1 MORE INFO + +For now, see servers using Danga::Socket for guidance. For example: +perlbal, mogilefsd, or ddlockd. + +=head1 AUTHORS + +Brad Fitzpatrick - author + +Michael Granger - docs, testing + +Mark Smith - contributor, heavy user, testing + +Matt Sergeant - kqueue support + +=head1 BUGS + +Not documented enough. + +tcp_cork only works on Linux for now. No BSD push/nopush support. + +=head1 LICENSE + +License is granted to use and distribute this module under the same +terms as Perl itself. =cut @@ -19,53 +103,53 @@ event-driven asynchronous IO. package Danga::Socket; use strict; +use bytes; +use POSIX (); +use Time::HiRes (); + +my $opt_bsd_resource = eval "use BSD::Resource; 1;"; use vars qw{$VERSION}; -$VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +$VERSION = "1.51"; -use fields qw(sock fd write_buf write_buf_offset write_buf_size - read_push_back post_loop_callback - peer_ip - closed event_watch debug_level); +use warnings; +no warnings qw(deprecated); -use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN - EPIPE EAGAIN EBADF ECONNRESET); +use Sys::Syscall qw(:epoll); +use fields ('sock', # underlying socket + 'fd', # numeric file descriptor + 'write_buf', # arrayref of scalars, scalarrefs, or coderefs to write + 'write_buf_offset', # offset into first array of write_buf to start writing at + 'write_buf_size', # total length of data in all write_buf items + 'read_push_back', # arrayref of "pushed-back" read data the application didn't want + 'closed', # bool: socket is closed + 'corked', # bool: socket is corked + 'event_watch', # bitmask of events the client is interested in (POLLIN,OUT,etc.) + 'peer_ip', # cached stringified IP address of $sock + 'peer_port', # cached port number of $sock + 'local_ip', # cached stringified IP address of local end of $sock + 'local_port', # cached port number of local end of $sock + 'writer_func', # subref which does writing. must return bytes written (or undef) and set $! on errors + ); + +use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN ENOTSOCK + EPIPE EAGAIN EBADF ECONNRESET ENOPROTOOPT); use Socket qw(IPPROTO_TCP); -use Carp qw{croak confess}; -use POSIX (); - -use constant TCP_CORK => 3; # FIXME: not hard-coded (Linux-specific too) +use Carp qw(croak confess); +use constant TCP_CORK => ($^O eq "linux" ? 3 : 0); # FIXME: not hard-coded (Linux-specific too) use constant DebugLevel => 0; -# for epoll definitions: -our $HAVE_SYSCALL_PH = eval { require 'syscall.ph'; 1 } || eval { require 'sys/syscall.ph'; 1 }; -our $HAVE_KQUEUE = eval { require IO::KQueue; 1 }; - -# Explicitly define the poll constants, as either one set or the other won't be -# loaded. They're also badly implemented in IO::Epoll: -# The IO::Epoll module is buggy in that it doesn't export constants efficiently -# (at least as of 0.01), so doing constants ourselves saves 13% of the user CPU -# time -use constant EPOLLIN => 1; -use constant EPOLLOUT => 4; -use constant EPOLLERR => 8; -use constant EPOLLHUP => 16; -use constant EPOLL_CTL_ADD => 1; -use constant EPOLL_CTL_DEL => 2; -use constant EPOLL_CTL_MOD => 3; - use constant POLLIN => 1; use constant POLLOUT => 4; use constant POLLERR => 8; use constant POLLHUP => 16; use constant POLLNVAL => 32; -# keep track of active clients +our $HAVE_KQUEUE = eval { require IO::KQueue; 1 }; + our ( - $DoneInit, # if we've done the one-time module init yet - $TryEpoll, # Whether epoll should be attempted to be used. $HaveEpoll, # Flag -- is epoll available? initially undefined. $HaveKQueue, %DescriptorMap, # fd (num) -> Danga::Socket object @@ -75,8 +159,14 @@ our ( @ToClose, # sockets to close when event loop is done %OtherFds, # A hash of "other" (non-Danga::Socket) file # descriptors for the event loop to track. - $PostLoopCallback, # subref to call at the end of each loop, if defined - %PLCMap, # fd (num) -> PostLoopCallback + + $PostLoopCallback, # subref to call at the end of each loop, if defined (global) + %PLCMap, # fd (num) -> PostLoopCallback (per-object) + + $LoopTimeout, # timeout of event loop in milliseconds + $DoProfile, # if on, enable profiling + %Profiling, # what => [ utime, stime, calls ] + $DoneInit, # if we've done the one-time module init yet @Timers, # timers ); @@ -86,21 +176,27 @@ Reset(); ### C L A S S M E T H O D S ##################################################################### -### (CLASS) METHOD: Reset() -### Reset all state +# (CLASS) method: reset all state sub Reset { %DescriptorMap = (); %PushBackSet = (); @ToClose = (); %OtherFds = (); + $LoopTimeout = -1; # no timeout by default + $DoProfile = 0; + %Profiling = (); + @Timers = (); + $PostLoopCallback = undef; %PLCMap = (); - @Timers = (); } ### (CLASS) METHOD: HaveEpoll() ### Returns a true value if this class will use IO::Epoll for async IO. -sub HaveEpoll { $HaveEpoll }; +sub HaveEpoll { + _InitPoller(); + return $HaveEpoll; +} ### (CLASS) METHOD: WatchedSockets() ### Returns the number of file descriptors which are registered with the global @@ -110,43 +206,95 @@ sub WatchedSockets { } *watched_sockets = *WatchedSockets; +### (CLASS) METHOD: EnableProfiling() +### Turns profiling on, clearing current profiling data. +sub EnableProfiling { + if ($opt_bsd_resource) { + %Profiling = (); + $DoProfile = 1; + return 1; + } + return 0; +} + +### (CLASS) METHOD: DisableProfiling() +### Turns off profiling, but retains data up to this point +sub DisableProfiling { + $DoProfile = 0; +} + +### (CLASS) METHOD: ProfilingData() +### Returns reference to a hash of data in format above (see %Profiling) +sub ProfilingData { + return \%Profiling; +} ### (CLASS) METHOD: ToClose() ### Return the list of sockets that are awaiting close() at the end of the ### current event loop. sub ToClose { return @ToClose; } - ### (CLASS) METHOD: OtherFds( [%fdmap] ) ### Get/set the hash of file descriptors that need processing in parallel with ### the registered Danga::Socket objects. sub OtherFds { my $class = shift; - if ( @_ ) { %OtherFds = (%OtherFds, @_) } + if ( @_ ) { %OtherFds = @_ } return wantarray ? %OtherFds : \%OtherFds; } +### (CLASS) METHOD: AddOtherFds( [%fdmap] ) +### Add fds to the OtherFds hash for processing. +sub AddOtherFds { + my $class = shift; + %OtherFds = ( %OtherFds, @_ ); # FIXME investigate what happens on dupe fds + return wantarray ? %OtherFds : \%OtherFds; +} + +### (CLASS) METHOD: SetLoopTimeout( $timeout ) +### Set the loop timeout for the event loop to some value in milliseconds. +sub SetLoopTimeout { + return $LoopTimeout = $_[1] + 0; +} + +### (CLASS) METHOD: DebugMsg( $format, @args ) +### Print the debugging message specified by the C-style I and +### I +sub DebugMsg { + my ( $class, $fmt, @args ) = @_; + chomp $fmt; + printf STDERR ">>> $fmt\n", @args; +} + +### (CLASS) METHOD: AddTimer( $seconds, $coderef ) +### Add a timer to occur $seconds from now. $seconds may be fractional. Don't +### expect this to be accurate though. sub AddTimer { my $class = shift; my ($secs, $coderef) = @_; - my $timeout = time + $secs; - - if (!@Timers || ($timeout >= $Timers[-1][0])) { - push @Timers, [$timeout, $coderef]; + + my $fire_time = Time::HiRes::time() + $secs; + + if (!@Timers || $fire_time >= $Timers[-1][0]) { + push @Timers, [$fire_time, $coderef]; return; } - - # Now where do we insert... + + # Now, where do we insert? (NOTE: this appears slow, algorithm-wise, + # but it was compared against calendar queues, heaps, naive push/sort, + # and a bunch of other versions, and found to be fastest with a large + # variety of datasets.) for (my $i = 0; $i < @Timers; $i++) { - if ($Timers[$i][0] > $timeout) { - splice(@Timers, $i, 0, [$timeout, $coderef]); + if ($Timers[$i][0] > $fire_time) { + splice(@Timers, $i, 0, [$fire_time, $coderef]); return; } } - - die "Shouldn't get here spank matt."; + + die "Shouldn't get here."; } + ### (CLASS) METHOD: DescriptorMap() ### Get the hash of Danga::Socket objects keyed by the file descriptor they are ### wrapping. @@ -156,11 +304,11 @@ sub DescriptorMap { *descriptor_map = *DescriptorMap; *get_sock_ref = *DescriptorMap; -sub init_poller +sub _InitPoller { return if $DoneInit; $DoneInit = 1; - + if ($HAVE_KQUEUE) { $KQueue = IO::KQueue->new(); $HaveKQueue = $KQueue >= 0; @@ -168,14 +316,14 @@ sub init_poller *EventLoop = *KQueueEventLoop; } } - elsif ($TryEpoll) { + elsif (Sys::Syscall::epoll_defined()) { $Epoll = eval { epoll_create(1024); }; $HaveEpoll = defined $Epoll && $Epoll >= 0; if ($HaveEpoll) { *EventLoop = *EpollEventLoop; } } - + if (!$HaveEpoll && !$HaveKQueue) { require IO::Poll; *EventLoop = *PollEventLoop; @@ -187,7 +335,7 @@ sub init_poller sub EventLoop { my $class = shift; - init_poller(); + _InitPoller(); if ($HaveEpoll) { EpollEventLoop($class); @@ -198,63 +346,55 @@ sub EventLoop { } } -### The kqueue-based event loop. Gets installed as EventLoop if IO::KQueue works -### okay. -sub KQueueEventLoop { - my $class = shift; - - foreach my $fd (keys %OtherFds) { - $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), IO::KQueue::EV_ADD()); +## profiling-related data/functions +our ($Prof_utime0, $Prof_stime0); +sub _pre_profile { + ($Prof_utime0, $Prof_stime0) = getrusage(); +} + +sub _post_profile { + # get post information + my ($autime, $astime) = getrusage(); + + # calculate differences + my $utime = $autime - $Prof_utime0; + my $stime = $astime - $Prof_stime0; + + foreach my $k (@_) { + $Profiling{$k} ||= [ 0.0, 0.0, 0 ]; + $Profiling{$k}->[0] += $utime; + $Profiling{$k}->[1] += $stime; + $Profiling{$k}->[2]++; } - - while (1) { - my $now = time; - # Run expired timers - while (@Timers && $Timers[0][0] <= $now) { - my $to_run = shift(@Timers); - $to_run->[1]->($now); - } - - # Get next timeout - my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; - # print STDERR "kevent($timeout)\n"; - my @ret = $KQueue->kevent($timeout * 1000); - - foreach my $kev (@ret) { - my ($fd, $filter, $flags, $fflags) = @$kev; - - my Danga::Socket $pob = $DescriptorMap{$fd}; - - # prioritise OtherFds first - likely to be accept() socks (?) - if (!$pob) { - if (my $code = $OtherFds{$fd}) { - $code->($filter); - } - else { - print STDERR "kevent() returned fd $fd for which we have no mapping. removing.\n"; - POSIX::close($fd); # close deletes the kevent entry - } - next; - } - - DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", - $fd, ref($pob), $flags, time); - - $pob->event_read if $filter == IO::KQueue::EVFILT_READ() && !$pob->{closed}; - $pob->event_write if $filter == IO::KQueue::EVFILT_WRITE() && !$pob->{closed}; - if ($flags == IO::KQueue::EV_EOF() && !$pob->{closed}) { - if ($fflags) { - $pob->event_err; - } else { - $pob->event_hup; - } - } - } - - return unless PostEventLoop(); +} + +# runs timers and returns milliseconds for next one, or next event loop +sub RunTimers { + return $LoopTimeout unless @Timers; + + my $now = Time::HiRes::time(); + + # Run expired timers + while (@Timers && $Timers[0][0] <= $now) { + my $to_run = shift(@Timers); + $to_run->[1]->($now); } - - exit(0); + + return $LoopTimeout unless @Timers; + + # convert time to an even number of milliseconds, adding 1 + # extra, otherwise floating point fun can occur and we'll + # call RunTimers like 20-30 times, each returning a timeout + # of 0.0000212 seconds + my $timeout = int(($Timers[0][0] - $now) * 1000) + 1; + + # -1 is an infinite timeout, so prefer a real timeout + return $timeout if $LoopTimeout == -1; + + # otherwise pick the lower of our regular timeout and time until + # the next timer + return $LoopTimeout if $LoopTimeout < $timeout; + return $timeout; } ### The epoll-based event loop. Gets installed as EventLoop if IO::Epoll loads @@ -263,24 +403,18 @@ sub EpollEventLoop { my $class = shift; foreach my $fd ( keys %OtherFds ) { - epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, EPOLLIN); + if (epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, EPOLLIN) == -1) { + warn "epoll_ctl(): failure adding fd=$fd; $! (", $!+0, ")\n"; + } } while (1) { - my $now = time; - # Run expired timers - while (@Timers && $Timers[0][0] <= $now) { - my $to_run = shift(@Timers); - $to_run->[1]->($now); - } - - # Get next timeout - my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; - my @events; my $i; - my $evcount = epoll_wait($Epoll, 1000, $timeout * 1000, \@events); - + my $timeout = RunTimers(); + + # get up to 1000 events + my $evcount = epoll_wait($Epoll, 1000, $timeout, \@events); EVENT: for ($i=0; $i<$evcount; $i++) { my $ev = $events[$i]; @@ -298,10 +432,9 @@ sub EpollEventLoop { if (! $pob) { if (my $code = $OtherFds{$ev->[0]}) { $code->($state); - } - else { + } else { my $fd = $ev->[0]; - print STDERR "epoll() returned fd $fd w/ state $state for which we have no mapping. removing.\n"; + warn "epoll() returned fd $fd w/ state $state for which we have no mapping. removing.\n"; POSIX::close($fd); epoll_ctl($Epoll, EPOLL_CTL_DEL, $fd, 0); } @@ -311,12 +444,46 @@ sub EpollEventLoop { DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", $ev->[0], ref($pob), $ev->[1], time); + if ($DoProfile) { + my $class = ref $pob; + + # call profiling action on things that need to be done + if ($state & EPOLLIN && ! $pob->{closed}) { + _pre_profile(); + $pob->event_read; + _post_profile("$class-read"); + } + + if ($state & EPOLLOUT && ! $pob->{closed}) { + _pre_profile(); + $pob->event_write; + _post_profile("$class-write"); + } + + if ($state & (EPOLLERR|EPOLLHUP)) { + if ($state & EPOLLERR && ! $pob->{closed}) { + _pre_profile(); + $pob->event_err; + _post_profile("$class-err"); + } + if ($state & EPOLLHUP && ! $pob->{closed}) { + _pre_profile(); + $pob->event_hup; + _post_profile("$class-hup"); + } + } + + next; + } + + # standard non-profiling codepat $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; - $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; - $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; + if ($state & (EPOLLERR|EPOLLHUP)) { + $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; + $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; + } } - return unless PostEventLoop(); } exit 0; @@ -330,16 +497,8 @@ sub PollEventLoop { my Danga::Socket $pob; while (1) { - my $now = time; - # Run expired timers - while (@Timers && $Timers[0][0] <= $now) { - my $to_run = shift(@Timers); - $to_run->[1]->($now); - } - - # Get next timeout - my $timeout = @Timers ? ($Timers[0][0] - $now) : 1; - + my $timeout = RunTimers(); + # the following sets up @poll as a series of ($poll,$event_mask) # items, then uses IO::Poll::_poll, implemented in XS, which # modifies the array in place with the even elements being @@ -348,14 +507,23 @@ sub PollEventLoop { foreach my $fd ( keys %OtherFds ) { push @poll, $fd, POLLIN; } - foreach my $fd ( keys %DescriptorMap ) { - my Danga::Socket $sock = $DescriptorMap{$fd}; + while ( my ($fd, $sock) = each %DescriptorMap ) { push @poll, $fd, $sock->{event_watch}; } - return 0 unless @poll; - - # print STDERR "Poll for $timeout secs\n"; - my $count = IO::Poll::_poll($timeout * 1000, @poll); + + # if nothing to poll, either end immediately (if no timeout) + # or just keep calling the callback + unless (@poll) { + select undef, undef, undef, ($timeout / 1000); + return unless PostEventLoop(); + next; + } + + my $count = IO::Poll::_poll($timeout, @poll); + unless ($count) { + return unless PostEventLoop(); + next; + } # Fetch handles with read events while (@poll) { @@ -364,8 +532,10 @@ sub PollEventLoop { $pob = $DescriptorMap{$fd}; - if ( !$pob && (my $code = $OtherFds{$fd}) ) { - $code->($state); + if (!$pob) { + if (my $code = $OtherFds{$fd}) { + $code->($state); + } next; } @@ -381,8 +551,84 @@ sub PollEventLoop { exit 0; } -## PostEventLoop is called at the end of the event loop to process things -# like close() calls. +### The kqueue-based event loop. Gets installed as EventLoop if IO::KQueue works +### okay. +sub KQueueEventLoop { + my $class = shift; + + foreach my $fd (keys %OtherFds) { + $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), IO::KQueue::EV_ADD()); + } + + while (1) { + my $timeout = RunTimers(); + my @ret = $KQueue->kevent($timeout); + if (!@ret) { + foreach my $fd ( keys %DescriptorMap ) { + my Danga::Socket $sock = $DescriptorMap{$fd}; + if ($sock->can('ticker')) { + $sock->ticker; + } + } + } + + foreach my $kev (@ret) { + my ($fd, $filter, $flags, $fflags) = @$kev; + my Danga::Socket $pob = $DescriptorMap{$fd}; + if (!$pob) { + if (my $code = $OtherFds{$fd}) { + $code->($filter); + } else { + warn "kevent() returned fd $fd for which we have no mapping. removing.\n"; + POSIX::close($fd); # close deletes the kevent entry + } + next; + } + + DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", + $fd, ref($pob), $flags, time); + + $pob->event_read if $filter == IO::KQueue::EVFILT_READ() && !$pob->{closed}; + $pob->event_write if $filter == IO::KQueue::EVFILT_WRITE() && !$pob->{closed}; + if ($flags == IO::KQueue::EV_EOF() && !$pob->{closed}) { + if ($fflags) { + $pob->event_err; + } else { + $pob->event_hup; + } + } + } + return unless PostEventLoop(); + } + + exit(0); +} + +### CLASS METHOD: SetPostLoopCallback +### Sets post loop callback function. Pass a subref and it will be +### called every time the event loop finishes. Return 1 from the sub +### to make the loop continue, else it will exit. The function will +### be passed two parameters: \%DescriptorMap, \%OtherFds. +sub SetPostLoopCallback { + my ($class, $ref) = @_; + + if (ref $class) { + # per-object callback + my Danga::Socket $self = $class; + if (defined $ref && ref $ref eq 'CODE') { + $PLCMap{$self->{fd}} = $ref; + } else { + delete $PLCMap{$self->{fd}}; + } + } else { + # global callback + $PostLoopCallback = (defined $ref && ref $ref eq 'CODE') ? $ref : undef; + } +} + +# Internal function: run the post-event callback, send read events +# for pushed-back data, and close pending connections. returns 1 +# if event loop should continue, or 0 to shut it all down. sub PostEventLoop { # fire read events for objects with pushed-back read data my $loop = 1; @@ -390,6 +636,14 @@ sub PostEventLoop { $loop = 0; foreach my $fd (keys %PushBackSet) { my Danga::Socket $pob = $PushBackSet{$fd}; + + # a previous event_read invocation could've closed a + # connection that we already evaluated in "keys + # %PushBackSet", so skip ones that seem to have + # disappeared. this is expected. + next unless $pob; + + die "ASSERT: the $pob socket has no read_push_back" unless @{$pob->{read_push_back}}; next unless (! $pob->{closed} && $pob->{event_watch} & POLLIN); $loop = 1; @@ -400,34 +654,38 @@ sub PostEventLoop { # now we can close sockets that wanted to close during our event processing. # (we didn't want to close them during the loop, as we didn't want fd numbers # being reused and confused during the event loop) - foreach my $f (@ToClose) { - close($f); - } - @ToClose = (); + while (my $sock = shift @ToClose) { + my $fd = fileno($sock); - # now we're at the very end, call per-connection callbacks if defined - my $ret = 1; # use $ret so's to not starve some FDs; return 0 if any PLCs return 0 + # close the socket. (not a Danga::Socket close) + $sock->close; + + # and now we can finally remove the fd from the map. see + # comment above in _cleanup. + delete $DescriptorMap{$fd}; + } + + + # by default we keep running, unless a postloop callback (either per-object + # or global) cancels it + my $keep_running = 1; + + # per-object post-loop-callbacks for my $plc (values %PLCMap) { - $ret &&= $plc->(\%DescriptorMap, \%OtherFds); + $keep_running &&= $plc->(\%DescriptorMap, \%OtherFds); } - # now we're at the very end, call global callback if defined + # now we're at the very end, call callback if defined if (defined $PostLoopCallback) { - $ret &&= $PostLoopCallback->(\%DescriptorMap, \%OtherFds); + $keep_running &&= $PostLoopCallback->(\%DescriptorMap, \%OtherFds); } - return $ret; -} - - -### (CLASS) METHOD: DebugMsg( $format, @args ) -### Print the debugging message specified by the C-style I and -### I -sub DebugMsg { - my ( $class, $fmt, @args ) = @_; - chomp $fmt; - printf STDERR ">>> $fmt\n", @args; + + return $keep_running; } +##################################################################### +### Danga::Socket-the-object code +##################################################################### ### METHOD: new( $socket ) ### Create a new Danga::Socket object for the given I which will react @@ -440,17 +698,21 @@ sub new { $self->{sock} = $sock; my $fd = fileno($sock); + + Carp::cluck("undef sock and/or fd in Danga::Socket->new. sock=" . ($sock || "") . ", fd=" . ($fd || "")) + unless $sock && $fd; + $self->{fd} = $fd; $self->{write_buf} = []; $self->{write_buf_offset} = 0; $self->{write_buf_size} = 0; $self->{closed} = 0; + $self->{corked} = 0; $self->{read_push_back} = []; - $self->{post_loop_callback} = undef; $self->{event_watch} = POLLERR|POLLHUP|POLLNVAL; - init_poller(); + _InitPoller(); if ($HaveEpoll) { epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, $self->{event_watch}) @@ -464,12 +726,14 @@ sub new { IO::KQueue::EV_ADD() | IO::KQueue::EV_DISABLE()); } + Carp::cluck("Danga::Socket::new blowing away existing descriptor map for fd=$fd ($DescriptorMap{$fd})") + if $DescriptorMap{$fd}; + $DescriptorMap{$fd} = $self; return $self; } - ##################################################################### ### I N S T A N C E M E T H O D S ##################################################################### @@ -477,22 +741,89 @@ sub new { ### METHOD: tcp_cork( $boolean ) ### Turn TCP_CORK on or off depending on the value of I. sub tcp_cork { - my Danga::Socket $self = shift; - my $val = shift; + my Danga::Socket $self = $_[0]; + my $val = $_[1]; - # FIXME: Linux-specific. - setsockopt($self->{sock}, IPPROTO_TCP, TCP_CORK, - pack("l", $val ? 1 : 0)) || die "setsockopt: $!"; + # make sure we have a socket + return unless $self->{sock}; + return if $val == $self->{corked}; + + my $rv; + if (TCP_CORK) { + $rv = setsockopt($self->{sock}, IPPROTO_TCP, TCP_CORK, + pack("l", $val ? 1 : 0)); + } else { + # FIXME: implement freebsd *PUSH sockopts + $rv = 1; + } + + # if we failed, close (if we're not already) and warn about the error + if ($rv) { + $self->{corked} = $val; + } else { + if ($! == EBADF || $! == ENOTSOCK) { + # internal state is probably corrupted; warn and then close if + # we're not closed already + warn "setsockopt: $!"; + $self->close('tcp_cork_failed'); + } elsif ($! == ENOPROTOOPT) { + # TCP implementation doesn't support corking, so just ignore it + } else { + # some other error; we should never hit here, but if we do, die + die "setsockopt: $!"; + } + } +} + +### METHOD: steal_socket +### Basically returns our socket and makes it so that we don't try to close it, +### but we do remove it from epoll handlers. THIS CLOSES $self. It is the same +### thing as calling close, except it gives you the socket to use. +sub steal_socket { + my Danga::Socket $self = $_[0]; + return if $self->{closed}; + + # cleanup does most of the work of closing this socket + $self->_cleanup(); + + # now undef our internal sock and fd structures so we don't use them + my $sock = $self->{sock}; + $self->{sock} = undef; + return $sock; } ### METHOD: close( [$reason] ) ### Close the socket. The I argument will be used in debugging messages. sub close { - my Danga::Socket $self = shift; - my $reason = shift || ""; + my Danga::Socket $self = $_[0]; + return if $self->{closed}; - my $fd = $self->{fd}; - my $sock = $self->{sock}; + # print out debugging info for this close + if (DebugLevel) { + my ($pkg, $filename, $line) = caller; + my $reason = $_[1] || ""; + warn "Closing \#$self->{fd} due to $pkg/$filename/$line ($reason)\n"; + } + + # this does most of the work of closing us + $self->_cleanup(); + + # defer closing the actual socket until the event loop is done + # processing this round of events. (otherwise we might reuse fds) + if ($self->{sock}) { + push @ToClose, $self->{sock}; + $self->{sock} = undef; + } + + return 0; +} + +### METHOD: _cleanup() +### Called by our closers so we can clean internal data structures. +sub _cleanup { + my Danga::Socket $self = $_[0]; + + # we're effectively closed; we have no fd and sock when we leave here $self->{closed} = 1; # we need to flush our write buffer, as there may @@ -500,32 +831,37 @@ sub close { # preventing the object from being destroyed $self->{write_buf} = []; - if (DebugLevel) { - my ($pkg, $filename, $line) = caller; - print STDERR "Closing \#$fd due to $pkg/$filename/$line ($reason)\n"; - } + # uncork so any final data gets sent. only matters if the person closing + # us forgot to do it, but we do it to be safe. + $self->tcp_cork(0); - if ($HaveEpoll) { - if (epoll_ctl($Epoll, EPOLL_CTL_DEL, $fd, $self->{event_watch}) == 0) { - DebugLevel >= 1 && $self->debugmsg("Client %d disconnected.\n", $fd); - } else { - DebugLevel >= 1 && $self->debugmsg("poll->remove failed on fd %d\n", $fd); + # if we're using epoll, we have to remove this from our epoll fd so we stop getting + # notifications about it + if ($HaveEpoll && $self->{fd}) { + if (epoll_ctl($Epoll, EPOLL_CTL_DEL, $self->{fd}, $self->{event_watch}) != 0) { + # dump_error prints a backtrace so we can try to figure out why this happened + $self->dump_error("epoll_ctl(): failure deleting fd=$self->{fd} during _cleanup(); $! (" . ($!+0) . ")"); } } - delete $PLCMap{$fd}; - delete $DescriptorMap{$fd}; - delete $PushBackSet{$fd}; + # now delete from mappings. this fd no longer belongs to us, so we don't want + # to get alerts for it if it becomes writable/readable/etc. + delete $PushBackSet{$self->{fd}}; + delete $PLCMap{$self->{fd}}; - # defer closing the actual socket until the event loop is done - # processing this round of events. (otherwise we might reuse fds) - push @ToClose, $sock; + # we explicitly don't delete from DescriptorMap here until we + # actually close the socket, as we might be in the middle of + # processing an epoll_wait/etc that returned hundreds of fds, one + # of which is not yet processed and is what we're closing. if we + # keep it in DescriptorMap, then the event harnesses can just + # looked at $pob->{closed} and ignore it. but if it's an + # un-accounted for fd, then it (understandably) freak out a bit + # and emit warnings, thinking their state got off. - return 0; + # and finally get rid of our fd so we can't use it anywhere else + $self->{fd} = undef; } - - ### METHOD: sock() ### Returns the underlying IO::Handle for the object. sub sock { @@ -533,6 +869,12 @@ sub sock { return $self->{sock}; } +sub set_writer_func { + my Danga::Socket $self = shift; + my $wtr = shift; + Carp::croak("Not a subref") unless !defined $wtr || ref $wtr eq "CODE"; + $self->{writer_func} = $wtr; +} ### METHOD: write( $data ) ### Write the specified data to the underlying handle. I may be scalar, @@ -587,6 +929,12 @@ sub write { shift @{$self->{write_buf}}; } $bref->(); + + # code refs are just run and never get reenqueued + # (they're one-shot), so turn off the flag indicating the + # outstanding data needs queueing. + $need_queue = 0; + undef $bref; next WRITE; } @@ -594,7 +942,12 @@ sub write { } my $to_write = $len - $self->{write_buf_offset}; - my $written = syswrite($self->{sock}, $$bref, $to_write, $self->{write_buf_offset}); + my $written; + if (my $wtr = $self->{writer_func}) { + $written = $wtr->($bref, $to_write, $self->{write_buf_offset}); + } else { + $written = syswrite($self->{sock}, $$bref, $to_write, $self->{write_buf_offset}); + } if (! defined $written) { if ($! == EPIPE) { @@ -626,7 +979,7 @@ sub write { # interested in pending writes: $self->{write_buf_offset} += $written; $self->{write_buf_size} -= $written; - $self->watch_write(1); + $self->on_incomplete_write; return 0; } elsif ($written == $to_write) { DebugLevel >= 2 && $self->debugmsg("Wrote ALL %d bytes to %d (nq=%d)", @@ -647,6 +1000,11 @@ sub write { } } +sub on_incomplete_write { + my Danga::Socket $self = shift; + $self->watch_write(1); +} + ### METHOD: push_back_read( $buf ) ### Push back I (a scalar or scalarref) into the read stream sub push_back_read { @@ -656,17 +1014,6 @@ sub push_back_read { $PushBackSet{$self->{fd}} = $self; } -### METHOD: shift_back_read( $buf ) -### Shift back I (a scalar or scalarref) into the read stream -### Use this instead of push_back_read() when you need to unread -### something you just read. -sub shift_back_read { - my Danga::Socket $self = shift; - my $buf = shift; - unshift @{$self->{read_push_back}}, ref $buf ? $buf : \$buf; - $PushBackSet{$self->{fd}} = $self; -} - ### METHOD: read( $bytecount ) ### Read at most I bytes from the underlying handle; returns scalar ### ref on read, or undef on connection closed. @@ -679,21 +1026,23 @@ sub read { if (@{$self->{read_push_back}}) { $buf = shift @{$self->{read_push_back}}; my $len = length($$buf); - if ($len <= $buf) { - unless (@{$self->{read_push_back}}) { - delete $PushBackSet{$self->{fd}}; - } + + if ($len <= $bytes) { + delete $PushBackSet{$self->{fd}} unless @{$self->{read_push_back}}; return $buf; } else { # if the pushed back read is too big, we have to split it my $overflow = substr($$buf, $bytes); $buf = substr($$buf, 0, $bytes); - unshift @{$self->{read_push_back}}, \$overflow, + unshift @{$self->{read_push_back}}, \$overflow; return \$buf; } } - my $res = sysread($sock, $buf, $bytes, 0); + # max 5MB, or perl quits(!!) + my $req_bytes = $bytes > 5242880 ? 5242880 : $bytes; + + my $res = sysread($sock, $buf, $req_bytes, 0); DebugLevel >= 2 && $self->debugmsg("sysread = %d; \$! = %d", $res, $!); if (! $res && $! != EWOULDBLOCK) { @@ -741,14 +1090,14 @@ sub event_write { ### Turn 'readable' event notification on or off. sub watch_read { my Danga::Socket $self = shift; - return if $self->{closed}; + return if $self->{closed} || !$self->{sock}; my $val = shift; my $event = $self->{event_watch}; - + $event &= ~POLLIN if ! $val; $event |= POLLIN if $val; - + # If it changed, set it if ($event != $self->{event_watch}) { if ($HaveKQueue) { @@ -757,22 +1106,22 @@ sub watch_read { } elsif ($HaveEpoll) { epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) - and print STDERR "couldn't modify epoll settings for $self->{fd} " . - "($self) from $self->{event_watch} -> $event\n"; + and $self->dump_error("couldn't modify epoll settings for $self->{fd} " . + "from $self->{event_watch} -> $event: $! (" . ($!+0) . ")"); } $self->{event_watch} = $event; } } -### METHOD: watch_read( $boolean ) +### METHOD: watch_write( $boolean ) ### Turn 'writable' event notification on or off. sub watch_write { my Danga::Socket $self = shift; - return if $self->{closed}; + return if $self->{closed} || !$self->{sock}; my $val = shift; my $event = $self->{event_watch}; - + $event &= ~POLLOUT if ! $val; $event |= POLLOUT if $val; @@ -784,13 +1133,28 @@ sub watch_write { } elsif ($HaveEpoll) { epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) - and print STDERR "couldn't modify epoll settings for $self->{fd} " . - "($self) from $self->{event_watch} -> $event\n"; + and $self->dump_error("couldn't modify epoll settings for $self->{fd} " . + "from $self->{event_watch} -> $event: $! (" . ($!+0) . ")"); } $self->{event_watch} = $event; } } +# METHOD: dump_error( $message ) +# Prints to STDERR a backtrace with information about this socket and what lead +# up to the dump_error call. +sub dump_error { + my $i = 0; + my @list; + while (my ($file, $line, $sub) = (caller($i++))[1..3]) { + push @list, "\t$file:$line called $sub\n"; + } + + warn "ERROR: $_[1]\n" . + "\t$_[0] = " . $_[0]->as_string . "\n" . + join('', @list); +} + ### METHOD: debugmsg( $format, @args ) ### Print the debugging message specified by the C-style I and @@ -809,12 +1173,16 @@ sub debugmsg { ### Returns the string describing the peer's IP sub peer_ip_string { my Danga::Socket $self = shift; - return $self->{peer_ip} if defined $self->{peer_ip}; - my $pn = getpeername($self->{sock}) or return undef; + return _undef("peer_ip_string undef: no sock") unless $self->{sock}; + return $self->{peer_ip} if defined $self->{peer_ip}; + + my $pn = getpeername($self->{sock}); + return _undef("peer_ip_string undef: getpeername") unless $pn; + my ($port, $iaddr) = Socket::sockaddr_in($pn); - my $r = Socket::inet_ntoa($iaddr); - $self->{peer_ip} = $r; - return $r; + $self->{peer_port} = $port; + + return $self->{peer_ip} = Socket::inet_ntoa($iaddr); } ### METHOD: peer_addr_string() @@ -822,16 +1190,43 @@ sub peer_ip_string { ### object in form "ip:port" sub peer_addr_string { my Danga::Socket $self = shift; - my $pn = getpeername($self->{sock}) or return undef; - my ($port, $iaddr) = Socket::sockaddr_in($pn); - return Socket::inet_ntoa($iaddr) . ":$port"; + my $ip = $self->peer_ip_string; + return $ip ? "$ip:$self->{peer_port}" : undef; } +### METHOD: local_ip_string() +### Returns the string describing the local IP +sub local_ip_string { + my Danga::Socket $self = shift; + return _undef("local_ip_string undef: no sock") unless $self->{sock}; + return $self->{local_ip} if defined $self->{local_ip}; + + my $pn = getsockname($self->{sock}); + return _undef("local_ip_string undef: getsockname") unless $pn; + + my ($port, $iaddr) = Socket::sockaddr_in($pn); + $self->{local_port} = $port; + + return $self->{local_ip} = Socket::inet_ntoa($iaddr); +} + +### METHOD: local_addr_string() +### Returns the string describing the local end of the socket which underlies this +### object in form "ip:port" +sub local_addr_string { + my Danga::Socket $self = shift; + my $ip = $self->local_ip_string; + return $ip ? "$ip:$self->{local_port}" : undef; +} + + ### METHOD: as_string() ### Returns a string describing this socket. sub as_string { my Danga::Socket $self = shift; - my $ret = ref($self) . ": " . ($self->{closed} ? "closed" : "open"); + my $rw = "(" . ($self->{event_watch} & POLLIN ? 'R' : '') . + ($self->{event_watch} & POLLOUT ? 'W' : '') . ")"; + my $ret = ref($self) . "$rw: " . ($self->{closed} ? "closed" : "open"); my $peer = $self->peer_addr_string; if ($peer) { $ret .= " to " . $self->peer_addr_string; @@ -839,140 +1234,15 @@ sub as_string { return $ret; } -### CLASS METHOD: SetPostLoopCallback -### Sets post loop callback function. Pass a subref and it will be -### called every time the event loop finishes. Return 1 from the sub -### to make the loop continue, else it will exit. The function will -### be passed two parameters: \%DescriptorMap, \%OtherFds. -sub SetPostLoopCallback { - my ($class, $ref) = @_; - if(ref $class) { - my Danga::Socket $self = $class; - if( defined $ref && ref $ref eq 'CODE' ) { - $PLCMap{$self->{fd}} = $ref; - } - else { - delete $PLCMap{$self->{fd}}; - } - } - else { - $PostLoopCallback = (defined $ref && ref $ref eq 'CODE') ? $ref : undef; - } -} - -sub DESTROY { - my Danga::Socket $self = shift; - $self->close() if !$self->{closed}; -} - -##################################################################### -### U T I L I T Y F U N C T I O N S -##################################################################### - -our ($SYS_epoll_create, $SYS_epoll_ctl, $SYS_epoll_wait); - -if ($^O eq "linux") { - my ($sysname, $nodename, $release, $version, $machine) = POSIX::uname(); - - # whether the machine requires 64-bit numbers to be on 8-byte - # boundaries. - my $u64_mod_8 = 0; - - if ($machine =~ m/^i[3456]86$/) { - $SYS_epoll_create = 254; - $SYS_epoll_ctl = 255; - $SYS_epoll_wait = 256; - } elsif ($machine eq "x86_64") { - $SYS_epoll_create = 213; - $SYS_epoll_ctl = 233; - $SYS_epoll_wait = 232; - } elsif ($machine eq "ppc64") { - $SYS_epoll_create = 236; - $SYS_epoll_ctl = 237; - $SYS_epoll_wait = 238; - $u64_mod_8 = 1; - } elsif ($machine eq "ppc") { - $SYS_epoll_create = 236; - $SYS_epoll_ctl = 237; - $SYS_epoll_wait = 238; - $u64_mod_8 = 1; - } elsif ($machine eq "ia64") { - $SYS_epoll_create = 1243; - $SYS_epoll_ctl = 1244; - $SYS_epoll_wait = 1245; - $u64_mod_8 = 1; - } - - if ($u64_mod_8) { - *epoll_wait = \&epoll_wait_mod8; - *epoll_ctl = \&epoll_ctl_mod8; - } else { - *epoll_wait = \&epoll_wait_mod4; - *epoll_ctl = \&epoll_ctl_mod4; - } - - # if syscall numbers have been defined (and this module has been - # tested on) the arch above, then try to use it. try means see if - # the syscall is implemented. it may well be that this is Linux - # 2.4 and we don't even have it available. - $TryEpoll = 1 if $SYS_epoll_create; -} - -# epoll_create wrapper -# ARGS: (size) -sub epoll_create { - my $epfd = eval { syscall($SYS_epoll_create, $_[0]) }; - return -1 if $@; - return $epfd; -} - -# epoll_ctl wrapper -# ARGS: (epfd, op, fd, events_mask) -sub epoll_ctl_mod4 { - syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLL", $_[3], $_[2], 0)); -} -sub epoll_ctl_mod8 { - syscall($SYS_epoll_ctl, $_[0]+0, $_[1]+0, $_[2]+0, pack("LLLL", $_[3], 0, $_[2], 0)); -} - -# epoll_wait wrapper -# ARGS: (epfd, maxevents, timeout (milliseconds), arrayref) -# arrayref: values modified to be [$fd, $event] -our $epoll_wait_events; -our $epoll_wait_size = 0; -sub epoll_wait_mod4 { - # resize our static buffer if requested size is bigger than we've ever done - if ($_[1] > $epoll_wait_size) { - $epoll_wait_size = $_[1]; - $epoll_wait_events = "\0" x 12 x $epoll_wait_size; - } - my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0); - for ($_ = 0; $_ < $ct; $_++) { - @{$_[3]->[$_]}[1,0] = unpack("LL", substr($epoll_wait_events, 12*$_, 8)); - } - return $ct; -} - -sub epoll_wait_mod8 { - # resize our static buffer if requested size is bigger than we've ever done - if ($_[1] > $epoll_wait_size) { - $epoll_wait_size = $_[1]; - $epoll_wait_events = "\0" x 16 x $epoll_wait_size; - } - my $ct = syscall($SYS_epoll_wait, $_[0]+0, $epoll_wait_events, $_[1]+0, $_[2]+0); - for ($_ = 0; $_ < $ct; $_++) { - # 16 byte epoll_event structs, with format: - # 4 byte mask [idx 1] - # 4 byte padding (we put it into idx 2, useless) - # 8 byte data (first 4 bytes are fd, into idx 0) - @{$_[3]->[$_]}[1,2,0] = unpack("LLL", substr($epoll_wait_events, 16*$_, 12)); - } - return $ct; +sub _undef { + return undef unless $ENV{DS_DEBUG}; + my $msg = shift || ""; + warn "Danga::Socket: $msg\n"; + return undef; } 1; - # Local Variables: # mode: perl # c-basic-indent: 4 diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm index dc01b48..0037643 100644 --- a/lib/Qpsmtpd.pm +++ b/lib/Qpsmtpd.pm @@ -337,7 +337,7 @@ sub run_hooks { @r = $self->run_hook($hook, $code, @_); next unless @r; if ($r[0] == CONTINUATION) { - $self->disable_read() if $self->isa('Danga::Client'); + $self->pause_read() if $self->isa('Danga::Client'); $self->{_continuation} = [$hook, [@_], @local_hooks]; } last unless $r[0] == DECLINED; @@ -351,7 +351,7 @@ sub run_hooks { sub finish_continuation { my ($self) = @_; die "No continuation in progress" unless $self->{_continuation}; - $self->enable_read() if $self->isa('Danga::Client'); + $self->continue_read() if $self->isa('Danga::Client'); my $todo = $self->{_continuation}; $self->{_continuation} = undef; my $hook = shift @$todo || die "No hook in the continuation"; @@ -361,7 +361,7 @@ sub finish_continuation { my $code = shift @$todo; @r = $self->run_hook($hook, $code, @$args); if ($r[0] == CONTINUATION) { - $self->disable_read() if $self->isa('Danga::Client'); + $self->pause_read() if $self->isa('Danga::Client'); $self->{_continuation} = [$hook, $args, @$todo]; return @r; } diff --git a/plugins/check_earlytalker b/plugins/check_earlytalker index feec4d8..3d145a4 100644 --- a/plugins/check_earlytalker +++ b/plugins/check_earlytalker @@ -44,6 +44,15 @@ issued a deny or denysoft (depending on the value of I). The default is to react at the SMTP greeting stage by issuing the apropriate response code and terminating the SMTP connection. +=item check-at [string: connect, data] + +Defines when to check for early talkers, either at connect time (pre-greet pause) +or at DATA time (pause before sending "354 go ahead"). + +The default is I. + +Note that defer-reject has no meaning if check-at is I. + =back =cut @@ -61,23 +70,27 @@ sub register { 'wait' => 1, 'action' => 'denysoft', 'defer-reject' => 0, + 'check-at' => 'connect', @args, }; + print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n"; if ($qp->isa('Qpsmtpd::Apache')) { require APR::Const; APR::Const->import(qw(POLLIN SUCCESS)); - $self->register_hook('connect', 'hook_connect_apr'); + $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_apr'); } else { - $self->register_hook('connect', 'hook_connect'); + $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll'); + } + $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post'); + if ($self->{_args}{'check-at'} eq 'connect') { + $self->register_hook('mail', 'hook_mail') + if $self->{_args}->{'defer-reject'}; } - $self->register_hook('connect', 'hook_connect_post'); - $self->register_hook('mail', 'hook_mail') - if $self->{_args}->{'defer-reject'}; 1; } -sub hook_connect_apr { +sub check_talker_apr { my ($self, $transaction) = @_; return DECLINED if ($self->qp->connection->notes('whitelistclient')); @@ -104,29 +117,27 @@ sub hook_connect_apr { return DECLINED; } -sub hook_connect { +sub check_talker_poll { my ($self, $transaction) = @_; my $qp = $self->qp; my $conn = $qp->connection; - $qp->AddTimer($self->{_args}{'wait'}, sub { read_now($qp, $conn) }); + $qp->AddTimer($self->{_args}{'wait'}, sub { read_now($qp, $conn, $self->{_args}{'check-at'}) }); return CONTINUATION; } sub read_now { - my ($qp, $conn) = @_; + my ($qp, $conn, $phase) = @_; - if (my $data = $qp->read(1024)) { - if (length($$data)) { + if ($qp->has_data) { $qp->log(LOGNOTICE, 'remote host started talking before we said hello'); - $qp->push_back_read($data); + $qp->clear_data if $phase eq 'data'; $conn->notes('earlytalker', 1); - } } $qp->finish_continuation; } -sub hook_connect_post { +sub check_talker_post { my ($self, $transaction) = @_; my $conn = $self->qp->connection; diff --git a/qpsmtpd b/qpsmtpd index 5ea6a39..83b6774 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -35,7 +35,6 @@ my $CONFIG_LOCALADDR = '127.0.0.1'; my $PORT = 2525; my $LOCALADDR = '0.0.0.0'; -my $LineMode = 0; my $PROCS = 1; my $MAXCONN = 15; # max simultaneous connections my $USER = 'smtpd'; # user to suid to @@ -54,7 +53,6 @@ Options: -c, --limit-connections N : limit concurrent connections to N; default 15 -u, --user U : run as a particular user; defualt 'smtpd' -m, --max-from-ip M : limit connections from a single IP; default 5 - -f, --forkmode : fork a child for each connection -j, --procs J : spawn J processes; default 1 -a, --accept K : accept up to K conns per loop; default 20 -h, --help : this page @@ -73,7 +71,6 @@ GetOptions( 'l|listen-address=s' => \$LOCALADDR, 'j|procs=i' => \$PROCS, 'd|debug+' => \$DEBUG, - 'f|forkmode' => \$LineMode, 'c|limit-connections=i' => \$MAXCONN, 'm|max-from-ip=i' => \$MAXCONNIP, 'u|user=s' => \$USER, @@ -90,8 +87,6 @@ if ($MAXCONN =~ /^(\d+)$/) { $MAXCONN = $1 } else { &help } if ($PROCS =~ /^(\d+)$/) { $PROCS = $1 } else { &help } if ($NUMACCEPT =~ /^(\d+)$/) { $NUMACCEPT = $1 } else { &help } my $_NUMACCEPT = $NUMACCEPT; -$::LineMode = $LineMode; -$PROCS = 1 if $LineMode; # This is a bit of a hack, but we get to approximate MAXCONN stuff when we # have multiple children listening on the same socket. $MAXCONN /= $PROCS; @@ -102,7 +97,7 @@ sub force_poll { $Danga::Socket::HaveKQueue = 0; } -Danga::Socket::init_poller(); +# Danga::Socket::init_poller(); my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : $Danga::Socket::HaveKQueue ? "kqueue()" : "poll()"); @@ -110,12 +105,6 @@ my $POLL = "with " . ($Danga::Socket::HaveEpoll ? "epoll()" : my $SERVER; my $CONFIG_SERVER; -# Code for inetd/tcpserver mode -if ($ENV{REMOTE_HOST} or $ENV{TCPREMOTEHOST}) { - run_as_inetd(); - exit(0); -} - my %childstatus = (); run_as_server(); @@ -165,8 +154,7 @@ sub sig_chld { print "child $child died\n"; delete $childstatus{$child}; } - return if $LineMode; - # restart a new child if in poll server mode + # restart a new child (assuming this one died) spawn_child(); $SIG{CHLD} = \&sig_chld; } @@ -177,33 +165,6 @@ sub HUNTSMAN { exit(0); } -sub run_as_inetd { - $LineMode = $::LineMode = 1; - - my $insock = IO::Handle->new_from_fd(0, "r"); - IO::Handle::blocking($insock, 0); - - my $outsock = IO::Handle->new_from_fd(1, "w"); - IO::Handle::blocking($outsock, 0); - - my $client = Danga::Client->new($insock); - - my $out = Qpsmtpd::PollServer->new($outsock); - $out->load_plugins; - $out->input_sock($client); - $client->push_back_read("Connect\n"); - # Cause poll/kevent/epoll to end quickly in first iteration - Qpsmtpd::PollServer->AddTimer(1, sub { }); - - while (1) { - $client->enable_read; - my $line = $client->get_line; - last if !defined($line); - my $output = $out->process_line($line); - $out->write($output) if $output; - } -} - sub run_as_server { local $::MAXconn = $MAXCONN; # establish SERVER socket, bind and listen. @@ -261,11 +222,7 @@ sub run_as_server { sleep while (1); } else { - if ($LineMode) { - $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; - } - $plugin_loader->log(LOGDEBUG, "Listening on $PORT with single process $POLL" . - ($LineMode ? " (forking server)" : "")); + $plugin_loader->log(LOGDEBUG, "Listening on $PORT with single process $POLL"); Qpsmtpd::PollServer->OtherFds(fileno($SERVER) => \&accept_handler, fileno($CONFIG_SERVER) => \&config_handler, ); @@ -298,13 +255,8 @@ sub config_handler { # Accept all new connections sub accept_handler { my $running; - if( $LineMode ) { - $running = scalar keys %childstatus; - } - else { - my $descriptors = Danga::Client->DescriptorMap; - $running = scalar keys %$descriptors; - } + my $descriptors = Danga::Client->DescriptorMap; + $running = scalar keys %$descriptors; for (1 .. $NUMACCEPT) { if ($running >= $MAXCONN) { @@ -349,93 +301,43 @@ sub _accept_handler { IO::Handle::blocking($csock, 0); setsockopt($csock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die; - if (!$LineMode) { - # multiplex mode - my $client = Qpsmtpd::PollServer->new($csock); - my $rem_ip = $client->peer_ip_string; - - if ($PAUSED) { - $client->write("451 Sorry, this server is currently paused\r\n"); - $client->close; - return 1; - } - - if ($MAXCONNIP) { - my $num_conn = 1; # seed with current value + # multiplex mode + my $client = Qpsmtpd::PollServer->new($csock); + my $rem_ip = $client->peer_ip_string; - # If we for-loop directly over values %childstatus, a SIGCHLD - # can call REAPER and slip $rip out from under us. Causes - # "Use of freed value in iteration" under perl 5.8.4. - my $descriptors = Danga::Client->DescriptorMap; - my @obj = values %$descriptors; - foreach my $obj (@obj) { - local $^W; - # This is a bit of a slow way to do this. Wish I could cache the method call. - ++$num_conn if ($obj->peer_ip_string eq $rem_ip); - } - - if ($num_conn > $MAXCONNIP) { - $client->log(LOGINFO,"Too many connections from $rem_ip: " - ."$num_conn > $MAXCONNIP. Denying connection."); - $client->write("451 Sorry, too many connections from $rem_ip, try again later\r\n"); - $client->close; - return 1; - } - $client->log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip"); - } - - $client->push_back_read("Connect\n"); - $client->watch_read(1); + if ($PAUSED) { + $client->write("451 Sorry, this server is currently paused\r\n"); + $client->close; return 1; } - - # fork-per-connection mode - my $rem_ip = $csock->sockhost(); if ($MAXCONNIP) { my $num_conn = 1; # seed with current value - my @rip = values %childstatus; - foreach my $rip (@rip) { - ++$num_conn if (defined $rip && $rip eq $rem_ip); + # If we for-loop directly over values %childstatus, a SIGCHLD + # can call REAPER and slip $rip out from under us. Causes + # "Use of freed value in iteration" under perl 5.8.4. + my $descriptors = Danga::Client->DescriptorMap; + my @obj = values %$descriptors; + foreach my $obj (@obj) { + local $^W; + # This is a bit of a slow way to do this. Wish I could cache the method call. + ++$num_conn if ($obj->peer_ip_string eq $rem_ip); } if ($num_conn > $MAXCONNIP) { - ::log(LOGINFO,"Too many connections from $rem_ip: " + $client->log(LOGINFO,"Too many connections from $rem_ip: " ."$num_conn > $MAXCONNIP. Denying connection."); - print $csock "451 Sorry, too many connections from $rem_ip, try again later\r\n"; - close $csock; + $client->write("451 Sorry, too many connections from $rem_ip, try again later\r\n"); + $client->close; return 1; } + $client->log(LOGINFO, "accepted connection $running/$MAXCONN ($num_conn/$MAXCONNIP) from $rem_ip"); } - if (my $pid = _fork) { - $childstatus{$pid} = $rem_ip; - return $csock->close(); - } - - $SERVER->close(); # make sure the child doesn't accept() new connections - - $SIG{$_} = 'DEFAULT' for keys %SIG; - - my $client = Qpsmtpd::PollServer->new($csock); $client->push_back_read("Connect\n"); - # Cause poll/kevent/epoll to end quickly in first iteration - Qpsmtpd::PollServer->AddTimer(0.1, sub { }); - - while (1) { - $client->enable_read; - my $line = $client->get_line; - last if !defined($line); - my $resp = $client->process_line($line); - $client->write($resp) if $resp; - } - - $client->log(LOGDEBUG, "Finished with child %d.\n", fileno($csock)) - if $DEBUG; - $client->close(); - - exit; + $client->watch_read(1); + return 1; } ######################################################################## From 5ff2ef7cacd3237699092fbbc58589ebff0169b9 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 20 Jun 2006 14:39:52 +0000 Subject: [PATCH 102/106] fields patch from Brian Grossman git-svn-id: https://svn.perl.org/qpsmtpd/trunk@644 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS/Resolver.pm | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 458fe36..47a9062 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -273,6 +273,8 @@ sub close { package Danga::DNS::Resolver::Query; +use fields qw( resolver asker host type timeout id data repeat ns nqueries ); + use constant MAX_QUERIES => 10; sub trace { @@ -281,24 +283,14 @@ sub trace { } sub new { - my ($class, $res, $asker, $host, $type, $now, $id, $data) = @_; + my Danga::DNS::Resolver::Query $self = shift; + $self = fields::new($self) unless ref $self; - my $self = { - resolver => $res, - asker => $asker, - host => $host, - type => $type, - timeout => $now, - id => $id, - data => $data, - repeat => 2, # number of retries - ns => 0, - nqueries => 0, - }; + @$self{qw( resolver asker host type timeout id data )} = @_; + # repeat is number of retries + @$self{qw( repeat ns nqueries )} = (2,0,0); - trace(2, "NS Query: $host ($id)\n"); - - bless $self, $class; + trace(2, "NS Query: $self->{host} ($self->{id})\n"); $self->send_query || return; From bcbe52f2f84bdfc4a0f9ee2963675f8ca0bf25bd Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 27 Jun 2006 20:28:36 +0000 Subject: [PATCH 103/106] stats plugin doesn't have a register() function any more (Brian Grossman) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@646 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/ConfigServer.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Qpsmtpd/ConfigServer.pm b/lib/Qpsmtpd/ConfigServer.pm index 2200cb0..ba9e065 100644 --- a/lib/Qpsmtpd/ConfigServer.pm +++ b/lib/Qpsmtpd/ConfigServer.pm @@ -155,7 +155,7 @@ sub cmd_status { my $output = "Current Status as of " . gmtime() . " GMT\n\n"; - if (defined &Qpsmtpd::Plugin::stats::register) { + if (defined &Qpsmtpd::Plugin::stats::get_stats) { # Stats plugin is loaded $output .= Qpsmtpd::Plugin::stats->get_stats; } @@ -282,4 +282,4 @@ When qpsmtpd runs in multiplex mode it also provides a config server that you can connect to. This allows you to view current connection statistics and other gumph that you probably don't care about. -=cut \ No newline at end of file +=cut From 22b589859bca231746eccd61a37801c079e22cdb Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 28 Jun 2006 00:06:18 +0000 Subject: [PATCH 104/106] Cleanup now we have no fork server in this script (Brian Grossman) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@647 958fd67b-6ff1-0310-b445-bb7760255be9 --- qpsmtpd | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/qpsmtpd b/qpsmtpd index 83b6774..c139011 100755 --- a/qpsmtpd +++ b/qpsmtpd @@ -58,9 +58,8 @@ Options: -h, --help : this page --use-poll : force use of poll() instead of epoll()/kqueue() -NB: -f and -j are mutually exclusive. If -f flag is not used the server uses -poll() style loops running inside J child processes. Set J to the number of -CPUs you have at your disposal. +NB: The server uses poll() style loops running inside J child processes. Set J +to the number of CPUs you have at your disposal. EOT exit(0); @@ -159,12 +158,6 @@ sub sig_chld { $SIG{CHLD} = \&sig_chld; } -sub HUNTSMAN { - $SIG{CHLD} = 'DEFAULT'; - kill 'INT' => keys %childstatus; - exit(0); -} - sub run_as_server { local $::MAXconn = $MAXCONN; # establish SERVER socket, bind and listen. From b000e35bf9652aa03a3963d3d318263925ef3996 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Wed, 28 Jun 2006 23:27:40 +0000 Subject: [PATCH 105/106] More fields work git-svn-id: https://svn.perl.org/qpsmtpd/trunk@649 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/DNS/Resolver.pm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/lib/Danga/DNS/Resolver.pm b/lib/Danga/DNS/Resolver.pm index 47a9062..950682e 100644 --- a/lib/Danga/DNS/Resolver.pm +++ b/lib/Danga/DNS/Resolver.pm @@ -303,7 +303,7 @@ sub new { #} sub timeout { - my $self = shift; + my Danga::DNS::Resolver::Query $self = shift; trace(2, "NS Query timeout. Trying next host\n"); if ($self->send_query) { @@ -329,7 +329,8 @@ sub timeout { } sub error { - my ($self, $error) = @_; + my Danga::DNS::Resolver::Query $self = shift; + my ($error) = @_; trace(2, "NS Query error. Trying next host\n"); if ($self->send_query) { @@ -355,13 +356,13 @@ sub error { } sub run_callback { - my ($self, $response) = @_; - trace(2, "NS Query callback($self->{host} = $response\n"); - $self->{asker}->run_callback($response, $self->{host}); + my Danga::DNS::Resolver::Query $self = shift; + trace(2, "NS Query callback($self->{host} = $_[0]\n"); + $self->{asker}->run_callback($_[0], $self->{host}); } sub send_query { - my ($self) = @_; + my Danga::DNS::Resolver::Query $self = shift; my $dst = $self->{resolver}->ns($self->{ns}++); return unless defined $dst; From 6a8111b6f677569c8af2697bd5830a78d2f80128 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Tue, 29 Aug 2006 16:51:34 +0000 Subject: [PATCH 106/106] Removed - CPAN version now very much up to date with this git-svn-id: https://svn.perl.org/qpsmtpd/trunk@658 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Danga/Socket.pm | 1250 ------------------------------------------- 1 file changed, 1250 deletions(-) delete mode 100644 lib/Danga/Socket.pm diff --git a/lib/Danga/Socket.pm b/lib/Danga/Socket.pm deleted file mode 100644 index 69cf219..0000000 --- a/lib/Danga/Socket.pm +++ /dev/null @@ -1,1250 +0,0 @@ -########################################################################### - -=head1 NAME - -Danga::Socket - Event loop and event-driven async socket base class - -=head1 SYNOPSIS - - package My::Socket - use Danga::Socket; - use base ('Danga::Socket'); - use fields ('my_attribute'); - - sub new { - my My::Socket $self = shift; - $self = fields::new($self) unless ref $self; - $self->SUPER::new( @_ ); - - $self->{my_attribute} = 1234; - return $self; - } - - sub event_err { ... } - sub event_hup { ... } - sub event_write { ... } - sub event_read { ... } - sub close { ... } - - $my_sock->tcp_cork($bool); - - # write returns 1 if all writes have gone through, or 0 if there - # are writes in queue - $my_sock->write($scalar); - $my_sock->write($scalarref); - $my_sock->write(sub { ... }); # run when previous data written - $my_sock->write(undef); # kick-starts - - # read max $bytecount bytes, or undef on connection closed - $scalar_ref = $my_sock->read($bytecount); - - # watch for writability. not needed with ->write(). write() - # will automatically turn on watch_write when you wrote too much - # and turn it off when done - $my_sock->watch_write($bool); - - # watch for readability - $my_sock->watch_read($bool); - - # if you read too much and want to push some back on - # readable queue. (not incredibly well-tested) - $my_sock->push_back_read($buf); # scalar or scalar ref - - Danga::Socket->AddOtherFds(..); - Danga::Socket->SetLoopTimeout($millisecs); - Danga::Socket->DescriptorMap(); - Danga::Socket->WatchedSockets(); # count of DescriptorMap keys - Danga::Socket->SetPostLoopCallback($code); - Danga::Socket->EventLoop(); - -=head1 DESCRIPTION - -This is an abstract base class for objects backed by a socket which -provides the basic framework for event-driven asynchronous IO, -designed to be fast. Danga::Socket is both a base class for objects, -and an event loop. - -Callers subclass Danga::Socket. Danga::Socket's constructor registers -itself with the Danga::Socket event loop, and invokes callbacks on the -object for readability, writability, errors, and other conditions. - -Because Danga::Socket uses the "fields" module, your subclasses must -too. - -=head1 MORE INFO - -For now, see servers using Danga::Socket for guidance. For example: -perlbal, mogilefsd, or ddlockd. - -=head1 AUTHORS - -Brad Fitzpatrick - author - -Michael Granger - docs, testing - -Mark Smith - contributor, heavy user, testing - -Matt Sergeant - kqueue support - -=head1 BUGS - -Not documented enough. - -tcp_cork only works on Linux for now. No BSD push/nopush support. - -=head1 LICENSE - -License is granted to use and distribute this module under the same -terms as Perl itself. - -=cut - -########################################################################### - -package Danga::Socket; -use strict; -use bytes; -use POSIX (); -use Time::HiRes (); - -my $opt_bsd_resource = eval "use BSD::Resource; 1;"; - -use vars qw{$VERSION}; -$VERSION = "1.51"; - -use warnings; -no warnings qw(deprecated); - -use Sys::Syscall qw(:epoll); - -use fields ('sock', # underlying socket - 'fd', # numeric file descriptor - 'write_buf', # arrayref of scalars, scalarrefs, or coderefs to write - 'write_buf_offset', # offset into first array of write_buf to start writing at - 'write_buf_size', # total length of data in all write_buf items - 'read_push_back', # arrayref of "pushed-back" read data the application didn't want - 'closed', # bool: socket is closed - 'corked', # bool: socket is corked - 'event_watch', # bitmask of events the client is interested in (POLLIN,OUT,etc.) - 'peer_ip', # cached stringified IP address of $sock - 'peer_port', # cached port number of $sock - 'local_ip', # cached stringified IP address of local end of $sock - 'local_port', # cached port number of local end of $sock - 'writer_func', # subref which does writing. must return bytes written (or undef) and set $! on errors - ); - -use Errno qw(EINPROGRESS EWOULDBLOCK EISCONN ENOTSOCK - EPIPE EAGAIN EBADF ECONNRESET ENOPROTOOPT); -use Socket qw(IPPROTO_TCP); -use Carp qw(croak confess); - -use constant TCP_CORK => ($^O eq "linux" ? 3 : 0); # FIXME: not hard-coded (Linux-specific too) -use constant DebugLevel => 0; - -use constant POLLIN => 1; -use constant POLLOUT => 4; -use constant POLLERR => 8; -use constant POLLHUP => 16; -use constant POLLNVAL => 32; - -our $HAVE_KQUEUE = eval { require IO::KQueue; 1 }; - -our ( - $HaveEpoll, # Flag -- is epoll available? initially undefined. - $HaveKQueue, - %DescriptorMap, # fd (num) -> Danga::Socket object - %PushBackSet, # fd (num) -> Danga::Socket (fds with pushed back read data) - $Epoll, # Global epoll fd (for epoll mode only) - $KQueue, # Global kqueue fd (for kqueue mode only) - @ToClose, # sockets to close when event loop is done - %OtherFds, # A hash of "other" (non-Danga::Socket) file - # descriptors for the event loop to track. - - $PostLoopCallback, # subref to call at the end of each loop, if defined (global) - %PLCMap, # fd (num) -> PostLoopCallback (per-object) - - $LoopTimeout, # timeout of event loop in milliseconds - $DoProfile, # if on, enable profiling - %Profiling, # what => [ utime, stime, calls ] - $DoneInit, # if we've done the one-time module init yet - @Timers, # timers - ); - -Reset(); - -##################################################################### -### C L A S S M E T H O D S -##################################################################### - -# (CLASS) method: reset all state -sub Reset { - %DescriptorMap = (); - %PushBackSet = (); - @ToClose = (); - %OtherFds = (); - $LoopTimeout = -1; # no timeout by default - $DoProfile = 0; - %Profiling = (); - @Timers = (); - - $PostLoopCallback = undef; - %PLCMap = (); -} - -### (CLASS) METHOD: HaveEpoll() -### Returns a true value if this class will use IO::Epoll for async IO. -sub HaveEpoll { - _InitPoller(); - return $HaveEpoll; -} - -### (CLASS) METHOD: WatchedSockets() -### Returns the number of file descriptors which are registered with the global -### poll object. -sub WatchedSockets { - return scalar keys %DescriptorMap; -} -*watched_sockets = *WatchedSockets; - -### (CLASS) METHOD: EnableProfiling() -### Turns profiling on, clearing current profiling data. -sub EnableProfiling { - if ($opt_bsd_resource) { - %Profiling = (); - $DoProfile = 1; - return 1; - } - return 0; -} - -### (CLASS) METHOD: DisableProfiling() -### Turns off profiling, but retains data up to this point -sub DisableProfiling { - $DoProfile = 0; -} - -### (CLASS) METHOD: ProfilingData() -### Returns reference to a hash of data in format above (see %Profiling) -sub ProfilingData { - return \%Profiling; -} - -### (CLASS) METHOD: ToClose() -### Return the list of sockets that are awaiting close() at the end of the -### current event loop. -sub ToClose { return @ToClose; } - -### (CLASS) METHOD: OtherFds( [%fdmap] ) -### Get/set the hash of file descriptors that need processing in parallel with -### the registered Danga::Socket objects. -sub OtherFds { - my $class = shift; - if ( @_ ) { %OtherFds = @_ } - return wantarray ? %OtherFds : \%OtherFds; -} - -### (CLASS) METHOD: AddOtherFds( [%fdmap] ) -### Add fds to the OtherFds hash for processing. -sub AddOtherFds { - my $class = shift; - %OtherFds = ( %OtherFds, @_ ); # FIXME investigate what happens on dupe fds - return wantarray ? %OtherFds : \%OtherFds; -} - -### (CLASS) METHOD: SetLoopTimeout( $timeout ) -### Set the loop timeout for the event loop to some value in milliseconds. -sub SetLoopTimeout { - return $LoopTimeout = $_[1] + 0; -} - -### (CLASS) METHOD: DebugMsg( $format, @args ) -### Print the debugging message specified by the C-style I and -### I -sub DebugMsg { - my ( $class, $fmt, @args ) = @_; - chomp $fmt; - printf STDERR ">>> $fmt\n", @args; -} - -### (CLASS) METHOD: AddTimer( $seconds, $coderef ) -### Add a timer to occur $seconds from now. $seconds may be fractional. Don't -### expect this to be accurate though. -sub AddTimer { - my $class = shift; - my ($secs, $coderef) = @_; - - my $fire_time = Time::HiRes::time() + $secs; - - if (!@Timers || $fire_time >= $Timers[-1][0]) { - push @Timers, [$fire_time, $coderef]; - return; - } - - # Now, where do we insert? (NOTE: this appears slow, algorithm-wise, - # but it was compared against calendar queues, heaps, naive push/sort, - # and a bunch of other versions, and found to be fastest with a large - # variety of datasets.) - for (my $i = 0; $i < @Timers; $i++) { - if ($Timers[$i][0] > $fire_time) { - splice(@Timers, $i, 0, [$fire_time, $coderef]); - return; - } - } - - die "Shouldn't get here."; -} - - -### (CLASS) METHOD: DescriptorMap() -### Get the hash of Danga::Socket objects keyed by the file descriptor they are -### wrapping. -sub DescriptorMap { - return wantarray ? %DescriptorMap : \%DescriptorMap; -} -*descriptor_map = *DescriptorMap; -*get_sock_ref = *DescriptorMap; - -sub _InitPoller -{ - return if $DoneInit; - $DoneInit = 1; - - if ($HAVE_KQUEUE) { - $KQueue = IO::KQueue->new(); - $HaveKQueue = $KQueue >= 0; - if ($HaveKQueue) { - *EventLoop = *KQueueEventLoop; - } - } - elsif (Sys::Syscall::epoll_defined()) { - $Epoll = eval { epoll_create(1024); }; - $HaveEpoll = defined $Epoll && $Epoll >= 0; - if ($HaveEpoll) { - *EventLoop = *EpollEventLoop; - } - } - - if (!$HaveEpoll && !$HaveKQueue) { - require IO::Poll; - *EventLoop = *PollEventLoop; - } -} - -### FUNCTION: EventLoop() -### Start processing IO events. -sub EventLoop { - my $class = shift; - - _InitPoller(); - - if ($HaveEpoll) { - EpollEventLoop($class); - } elsif ($HaveKQueue) { - KQueueEventLoop($class); - } else { - PollEventLoop($class); - } -} - -## profiling-related data/functions -our ($Prof_utime0, $Prof_stime0); -sub _pre_profile { - ($Prof_utime0, $Prof_stime0) = getrusage(); -} - -sub _post_profile { - # get post information - my ($autime, $astime) = getrusage(); - - # calculate differences - my $utime = $autime - $Prof_utime0; - my $stime = $astime - $Prof_stime0; - - foreach my $k (@_) { - $Profiling{$k} ||= [ 0.0, 0.0, 0 ]; - $Profiling{$k}->[0] += $utime; - $Profiling{$k}->[1] += $stime; - $Profiling{$k}->[2]++; - } -} - -# runs timers and returns milliseconds for next one, or next event loop -sub RunTimers { - return $LoopTimeout unless @Timers; - - my $now = Time::HiRes::time(); - - # Run expired timers - while (@Timers && $Timers[0][0] <= $now) { - my $to_run = shift(@Timers); - $to_run->[1]->($now); - } - - return $LoopTimeout unless @Timers; - - # convert time to an even number of milliseconds, adding 1 - # extra, otherwise floating point fun can occur and we'll - # call RunTimers like 20-30 times, each returning a timeout - # of 0.0000212 seconds - my $timeout = int(($Timers[0][0] - $now) * 1000) + 1; - - # -1 is an infinite timeout, so prefer a real timeout - return $timeout if $LoopTimeout == -1; - - # otherwise pick the lower of our regular timeout and time until - # the next timer - return $LoopTimeout if $LoopTimeout < $timeout; - return $timeout; -} - -### The epoll-based event loop. Gets installed as EventLoop if IO::Epoll loads -### okay. -sub EpollEventLoop { - my $class = shift; - - foreach my $fd ( keys %OtherFds ) { - if (epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, EPOLLIN) == -1) { - warn "epoll_ctl(): failure adding fd=$fd; $! (", $!+0, ")\n"; - } - } - - while (1) { - my @events; - my $i; - my $timeout = RunTimers(); - - # get up to 1000 events - my $evcount = epoll_wait($Epoll, 1000, $timeout, \@events); - EVENT: - for ($i=0; $i<$evcount; $i++) { - my $ev = $events[$i]; - - # it's possible epoll_wait returned many events, including some at the end - # that ones in the front triggered unregister-interest actions. if we - # can't find the %sock entry, it's because we're no longer interested - # in that event. - my Danga::Socket $pob = $DescriptorMap{$ev->[0]}; - my $code; - my $state = $ev->[1]; - - # if we didn't find a Perlbal::Socket subclass for that fd, try other - # pseudo-registered (above) fds. - if (! $pob) { - if (my $code = $OtherFds{$ev->[0]}) { - $code->($state); - } else { - my $fd = $ev->[0]; - warn "epoll() returned fd $fd w/ state $state for which we have no mapping. removing.\n"; - POSIX::close($fd); - epoll_ctl($Epoll, EPOLL_CTL_DEL, $fd, 0); - } - next; - } - - DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), state=%d \@ %s\n", - $ev->[0], ref($pob), $ev->[1], time); - - if ($DoProfile) { - my $class = ref $pob; - - # call profiling action on things that need to be done - if ($state & EPOLLIN && ! $pob->{closed}) { - _pre_profile(); - $pob->event_read; - _post_profile("$class-read"); - } - - if ($state & EPOLLOUT && ! $pob->{closed}) { - _pre_profile(); - $pob->event_write; - _post_profile("$class-write"); - } - - if ($state & (EPOLLERR|EPOLLHUP)) { - if ($state & EPOLLERR && ! $pob->{closed}) { - _pre_profile(); - $pob->event_err; - _post_profile("$class-err"); - } - if ($state & EPOLLHUP && ! $pob->{closed}) { - _pre_profile(); - $pob->event_hup; - _post_profile("$class-hup"); - } - } - - next; - } - - # standard non-profiling codepat - $pob->event_read if $state & EPOLLIN && ! $pob->{closed}; - $pob->event_write if $state & EPOLLOUT && ! $pob->{closed}; - if ($state & (EPOLLERR|EPOLLHUP)) { - $pob->event_err if $state & EPOLLERR && ! $pob->{closed}; - $pob->event_hup if $state & EPOLLHUP && ! $pob->{closed}; - } - } - return unless PostEventLoop(); - } - exit 0; -} - -### The fallback IO::Poll-based event loop. Gets installed as EventLoop if -### IO::Epoll fails to load. -sub PollEventLoop { - my $class = shift; - - my Danga::Socket $pob; - - while (1) { - my $timeout = RunTimers(); - - # the following sets up @poll as a series of ($poll,$event_mask) - # items, then uses IO::Poll::_poll, implemented in XS, which - # modifies the array in place with the even elements being - # replaced with the event masks that occured. - my @poll; - foreach my $fd ( keys %OtherFds ) { - push @poll, $fd, POLLIN; - } - while ( my ($fd, $sock) = each %DescriptorMap ) { - push @poll, $fd, $sock->{event_watch}; - } - - # if nothing to poll, either end immediately (if no timeout) - # or just keep calling the callback - unless (@poll) { - select undef, undef, undef, ($timeout / 1000); - return unless PostEventLoop(); - next; - } - - my $count = IO::Poll::_poll($timeout, @poll); - unless ($count) { - return unless PostEventLoop(); - next; - } - - # Fetch handles with read events - while (@poll) { - my ($fd, $state) = splice(@poll, 0, 2); - next unless $state; - - $pob = $DescriptorMap{$fd}; - - if (!$pob) { - if (my $code = $OtherFds{$fd}) { - $code->($state); - } - next; - } - - $pob->event_read if $state & POLLIN && ! $pob->{closed}; - $pob->event_write if $state & POLLOUT && ! $pob->{closed}; - $pob->event_err if $state & POLLERR && ! $pob->{closed}; - $pob->event_hup if $state & POLLHUP && ! $pob->{closed}; - } - - return unless PostEventLoop(); - } - - exit 0; -} - -### The kqueue-based event loop. Gets installed as EventLoop if IO::KQueue works -### okay. -sub KQueueEventLoop { - my $class = shift; - - foreach my $fd (keys %OtherFds) { - $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), IO::KQueue::EV_ADD()); - } - - while (1) { - my $timeout = RunTimers(); - my @ret = $KQueue->kevent($timeout); - if (!@ret) { - foreach my $fd ( keys %DescriptorMap ) { - my Danga::Socket $sock = $DescriptorMap{$fd}; - if ($sock->can('ticker')) { - $sock->ticker; - } - } - } - - foreach my $kev (@ret) { - my ($fd, $filter, $flags, $fflags) = @$kev; - my Danga::Socket $pob = $DescriptorMap{$fd}; - if (!$pob) { - if (my $code = $OtherFds{$fd}) { - $code->($filter); - } else { - warn "kevent() returned fd $fd for which we have no mapping. removing.\n"; - POSIX::close($fd); # close deletes the kevent entry - } - next; - } - - DebugLevel >= 1 && $class->DebugMsg("Event: fd=%d (%s), flags=%d \@ %s\n", - $fd, ref($pob), $flags, time); - - $pob->event_read if $filter == IO::KQueue::EVFILT_READ() && !$pob->{closed}; - $pob->event_write if $filter == IO::KQueue::EVFILT_WRITE() && !$pob->{closed}; - if ($flags == IO::KQueue::EV_EOF() && !$pob->{closed}) { - if ($fflags) { - $pob->event_err; - } else { - $pob->event_hup; - } - } - } - return unless PostEventLoop(); - } - - exit(0); -} - -### CLASS METHOD: SetPostLoopCallback -### Sets post loop callback function. Pass a subref and it will be -### called every time the event loop finishes. Return 1 from the sub -### to make the loop continue, else it will exit. The function will -### be passed two parameters: \%DescriptorMap, \%OtherFds. -sub SetPostLoopCallback { - my ($class, $ref) = @_; - - if (ref $class) { - # per-object callback - my Danga::Socket $self = $class; - if (defined $ref && ref $ref eq 'CODE') { - $PLCMap{$self->{fd}} = $ref; - } else { - delete $PLCMap{$self->{fd}}; - } - } else { - # global callback - $PostLoopCallback = (defined $ref && ref $ref eq 'CODE') ? $ref : undef; - } -} - -# Internal function: run the post-event callback, send read events -# for pushed-back data, and close pending connections. returns 1 -# if event loop should continue, or 0 to shut it all down. -sub PostEventLoop { - # fire read events for objects with pushed-back read data - my $loop = 1; - while ($loop) { - $loop = 0; - foreach my $fd (keys %PushBackSet) { - my Danga::Socket $pob = $PushBackSet{$fd}; - - # a previous event_read invocation could've closed a - # connection that we already evaluated in "keys - # %PushBackSet", so skip ones that seem to have - # disappeared. this is expected. - next unless $pob; - - die "ASSERT: the $pob socket has no read_push_back" unless @{$pob->{read_push_back}}; - next unless (! $pob->{closed} && - $pob->{event_watch} & POLLIN); - $loop = 1; - $pob->event_read; - } - } - - # now we can close sockets that wanted to close during our event processing. - # (we didn't want to close them during the loop, as we didn't want fd numbers - # being reused and confused during the event loop) - while (my $sock = shift @ToClose) { - my $fd = fileno($sock); - - # close the socket. (not a Danga::Socket close) - $sock->close; - - # and now we can finally remove the fd from the map. see - # comment above in _cleanup. - delete $DescriptorMap{$fd}; - } - - - # by default we keep running, unless a postloop callback (either per-object - # or global) cancels it - my $keep_running = 1; - - # per-object post-loop-callbacks - for my $plc (values %PLCMap) { - $keep_running &&= $plc->(\%DescriptorMap, \%OtherFds); - } - - # now we're at the very end, call callback if defined - if (defined $PostLoopCallback) { - $keep_running &&= $PostLoopCallback->(\%DescriptorMap, \%OtherFds); - } - - return $keep_running; -} - -##################################################################### -### Danga::Socket-the-object code -##################################################################### - -### METHOD: new( $socket ) -### Create a new Danga::Socket object for the given I which will react -### to events on it during the C. -sub new { - my Danga::Socket $self = shift; - $self = fields::new($self) unless ref $self; - - my $sock = shift; - - $self->{sock} = $sock; - my $fd = fileno($sock); - - Carp::cluck("undef sock and/or fd in Danga::Socket->new. sock=" . ($sock || "") . ", fd=" . ($fd || "")) - unless $sock && $fd; - - $self->{fd} = $fd; - $self->{write_buf} = []; - $self->{write_buf_offset} = 0; - $self->{write_buf_size} = 0; - $self->{closed} = 0; - $self->{corked} = 0; - $self->{read_push_back} = []; - - $self->{event_watch} = POLLERR|POLLHUP|POLLNVAL; - - _InitPoller(); - - if ($HaveEpoll) { - epoll_ctl($Epoll, EPOLL_CTL_ADD, $fd, $self->{event_watch}) - and die "couldn't add epoll watch for $fd\n"; - } - elsif ($HaveKQueue) { - # Add them to the queue but disabled for now - $KQueue->EV_SET($fd, IO::KQueue::EVFILT_READ(), - IO::KQueue::EV_ADD() | IO::KQueue::EV_DISABLE()); - $KQueue->EV_SET($fd, IO::KQueue::EVFILT_WRITE(), - IO::KQueue::EV_ADD() | IO::KQueue::EV_DISABLE()); - } - - Carp::cluck("Danga::Socket::new blowing away existing descriptor map for fd=$fd ($DescriptorMap{$fd})") - if $DescriptorMap{$fd}; - - $DescriptorMap{$fd} = $self; - return $self; -} - - -##################################################################### -### I N S T A N C E M E T H O D S -##################################################################### - -### METHOD: tcp_cork( $boolean ) -### Turn TCP_CORK on or off depending on the value of I. -sub tcp_cork { - my Danga::Socket $self = $_[0]; - my $val = $_[1]; - - # make sure we have a socket - return unless $self->{sock}; - return if $val == $self->{corked}; - - my $rv; - if (TCP_CORK) { - $rv = setsockopt($self->{sock}, IPPROTO_TCP, TCP_CORK, - pack("l", $val ? 1 : 0)); - } else { - # FIXME: implement freebsd *PUSH sockopts - $rv = 1; - } - - # if we failed, close (if we're not already) and warn about the error - if ($rv) { - $self->{corked} = $val; - } else { - if ($! == EBADF || $! == ENOTSOCK) { - # internal state is probably corrupted; warn and then close if - # we're not closed already - warn "setsockopt: $!"; - $self->close('tcp_cork_failed'); - } elsif ($! == ENOPROTOOPT) { - # TCP implementation doesn't support corking, so just ignore it - } else { - # some other error; we should never hit here, but if we do, die - die "setsockopt: $!"; - } - } -} - -### METHOD: steal_socket -### Basically returns our socket and makes it so that we don't try to close it, -### but we do remove it from epoll handlers. THIS CLOSES $self. It is the same -### thing as calling close, except it gives you the socket to use. -sub steal_socket { - my Danga::Socket $self = $_[0]; - return if $self->{closed}; - - # cleanup does most of the work of closing this socket - $self->_cleanup(); - - # now undef our internal sock and fd structures so we don't use them - my $sock = $self->{sock}; - $self->{sock} = undef; - return $sock; -} - -### METHOD: close( [$reason] ) -### Close the socket. The I argument will be used in debugging messages. -sub close { - my Danga::Socket $self = $_[0]; - return if $self->{closed}; - - # print out debugging info for this close - if (DebugLevel) { - my ($pkg, $filename, $line) = caller; - my $reason = $_[1] || ""; - warn "Closing \#$self->{fd} due to $pkg/$filename/$line ($reason)\n"; - } - - # this does most of the work of closing us - $self->_cleanup(); - - # defer closing the actual socket until the event loop is done - # processing this round of events. (otherwise we might reuse fds) - if ($self->{sock}) { - push @ToClose, $self->{sock}; - $self->{sock} = undef; - } - - return 0; -} - -### METHOD: _cleanup() -### Called by our closers so we can clean internal data structures. -sub _cleanup { - my Danga::Socket $self = $_[0]; - - # we're effectively closed; we have no fd and sock when we leave here - $self->{closed} = 1; - - # we need to flush our write buffer, as there may - # be self-referential closures (sub { $client->close }) - # preventing the object from being destroyed - $self->{write_buf} = []; - - # uncork so any final data gets sent. only matters if the person closing - # us forgot to do it, but we do it to be safe. - $self->tcp_cork(0); - - # if we're using epoll, we have to remove this from our epoll fd so we stop getting - # notifications about it - if ($HaveEpoll && $self->{fd}) { - if (epoll_ctl($Epoll, EPOLL_CTL_DEL, $self->{fd}, $self->{event_watch}) != 0) { - # dump_error prints a backtrace so we can try to figure out why this happened - $self->dump_error("epoll_ctl(): failure deleting fd=$self->{fd} during _cleanup(); $! (" . ($!+0) . ")"); - } - } - - # now delete from mappings. this fd no longer belongs to us, so we don't want - # to get alerts for it if it becomes writable/readable/etc. - delete $PushBackSet{$self->{fd}}; - delete $PLCMap{$self->{fd}}; - - # we explicitly don't delete from DescriptorMap here until we - # actually close the socket, as we might be in the middle of - # processing an epoll_wait/etc that returned hundreds of fds, one - # of which is not yet processed and is what we're closing. if we - # keep it in DescriptorMap, then the event harnesses can just - # looked at $pob->{closed} and ignore it. but if it's an - # un-accounted for fd, then it (understandably) freak out a bit - # and emit warnings, thinking their state got off. - - # and finally get rid of our fd so we can't use it anywhere else - $self->{fd} = undef; -} - -### METHOD: sock() -### Returns the underlying IO::Handle for the object. -sub sock { - my Danga::Socket $self = shift; - return $self->{sock}; -} - -sub set_writer_func { - my Danga::Socket $self = shift; - my $wtr = shift; - Carp::croak("Not a subref") unless !defined $wtr || ref $wtr eq "CODE"; - $self->{writer_func} = $wtr; -} - -### METHOD: write( $data ) -### Write the specified data to the underlying handle. I may be scalar, -### scalar ref, code ref (to run when there), or undef just to kick-start. -### Returns 1 if writes all went through, or 0 if there are writes in queue. If -### it returns 1, caller should stop waiting for 'writable' events) -sub write { - my Danga::Socket $self; - my $data; - ($self, $data) = @_; - - # nobody should be writing to closed sockets, but caller code can - # do two writes within an event, have the first fail and - # disconnect the other side (whose destructor then closes the - # calling object, but it's still in a method), and then the - # now-dead object does its second write. that is this case. we - # just lie and say it worked. it'll be dead soon and won't be - # hurt by this lie. - return 1 if $self->{closed}; - - my $bref; - - # just queue data if there's already a wait - my $need_queue; - - if (defined $data) { - $bref = ref $data ? $data : \$data; - if ($self->{write_buf_size}) { - push @{$self->{write_buf}}, $bref; - $self->{write_buf_size} += ref $bref eq "SCALAR" ? length($$bref) : 1; - return 0; - } - - # this flag says we're bypassing the queue system, knowing we're the - # only outstanding write, and hoping we don't ever need to use it. - # if so later, though, we'll need to queue - $need_queue = 1; - } - - WRITE: - while (1) { - return 1 unless $bref ||= $self->{write_buf}[0]; - - my $len; - eval { - $len = length($$bref); # this will die if $bref is a code ref, caught below - }; - if ($@) { - if (ref $bref eq "CODE") { - unless ($need_queue) { - $self->{write_buf_size}--; # code refs are worth 1 - shift @{$self->{write_buf}}; - } - $bref->(); - - # code refs are just run and never get reenqueued - # (they're one-shot), so turn off the flag indicating the - # outstanding data needs queueing. - $need_queue = 0; - - undef $bref; - next WRITE; - } - die "Write error: $@ <$bref>"; - } - - my $to_write = $len - $self->{write_buf_offset}; - my $written; - if (my $wtr = $self->{writer_func}) { - $written = $wtr->($bref, $to_write, $self->{write_buf_offset}); - } else { - $written = syswrite($self->{sock}, $$bref, $to_write, $self->{write_buf_offset}); - } - - if (! defined $written) { - if ($! == EPIPE) { - return $self->close("EPIPE"); - } elsif ($! == EAGAIN) { - # since connection has stuff to write, it should now be - # interested in pending writes: - if ($need_queue) { - push @{$self->{write_buf}}, $bref; - $self->{write_buf_size} += $len; - } - $self->watch_write(1); - return 0; - } elsif ($! == ECONNRESET) { - return $self->close("ECONNRESET"); - } - - DebugLevel >= 1 && $self->debugmsg("Closing connection ($self) due to write error: $!\n"); - - return $self->close("write_error"); - } elsif ($written != $to_write) { - DebugLevel >= 2 && $self->debugmsg("Wrote PARTIAL %d bytes to %d", - $written, $self->{fd}); - if ($need_queue) { - push @{$self->{write_buf}}, $bref; - $self->{write_buf_size} += $len; - } - # since connection has stuff to write, it should now be - # interested in pending writes: - $self->{write_buf_offset} += $written; - $self->{write_buf_size} -= $written; - $self->on_incomplete_write; - return 0; - } elsif ($written == $to_write) { - DebugLevel >= 2 && $self->debugmsg("Wrote ALL %d bytes to %d (nq=%d)", - $written, $self->{fd}, $need_queue); - $self->{write_buf_offset} = 0; - - # this was our only write, so we can return immediately - # since we avoided incrementing the buffer size or - # putting it in the buffer. we also know there - # can't be anything else to write. - return 1 if $need_queue; - - $self->{write_buf_size} -= $written; - shift @{$self->{write_buf}}; - undef $bref; - next WRITE; - } - } -} - -sub on_incomplete_write { - my Danga::Socket $self = shift; - $self->watch_write(1); -} - -### METHOD: push_back_read( $buf ) -### Push back I (a scalar or scalarref) into the read stream -sub push_back_read { - my Danga::Socket $self = shift; - my $buf = shift; - push @{$self->{read_push_back}}, ref $buf ? $buf : \$buf; - $PushBackSet{$self->{fd}} = $self; -} - -### METHOD: read( $bytecount ) -### Read at most I bytes from the underlying handle; returns scalar -### ref on read, or undef on connection closed. -sub read { - my Danga::Socket $self = shift; - my $bytes = shift; - my $buf; - my $sock = $self->{sock}; - - if (@{$self->{read_push_back}}) { - $buf = shift @{$self->{read_push_back}}; - my $len = length($$buf); - - if ($len <= $bytes) { - delete $PushBackSet{$self->{fd}} unless @{$self->{read_push_back}}; - return $buf; - } else { - # if the pushed back read is too big, we have to split it - my $overflow = substr($$buf, $bytes); - $buf = substr($$buf, 0, $bytes); - unshift @{$self->{read_push_back}}, \$overflow; - return \$buf; - } - } - - # max 5MB, or perl quits(!!) - my $req_bytes = $bytes > 5242880 ? 5242880 : $bytes; - - my $res = sysread($sock, $buf, $req_bytes, 0); - DebugLevel >= 2 && $self->debugmsg("sysread = %d; \$! = %d", $res, $!); - - if (! $res && $! != EWOULDBLOCK) { - # catches 0=conn closed or undef=error - DebugLevel >= 2 && $self->debugmsg("Fd \#%d read hit the end of the road.", $self->{fd}); - return undef; - } - - return \$buf; -} - - -### (VIRTUAL) METHOD: event_read() -### Readable event handler. Concrete deriviatives of Danga::Socket should -### provide an implementation of this. The default implementation will die if -### called. -sub event_read { die "Base class event_read called for $_[0]\n"; } - - -### (VIRTUAL) METHOD: event_err() -### Error event handler. Concrete deriviatives of Danga::Socket should -### provide an implementation of this. The default implementation will die if -### called. -sub event_err { die "Base class event_err called for $_[0]\n"; } - - -### (VIRTUAL) METHOD: event_hup() -### 'Hangup' event handler. Concrete deriviatives of Danga::Socket should -### provide an implementation of this. The default implementation will die if -### called. -sub event_hup { die "Base class event_hup called for $_[0]\n"; } - - -### METHOD: event_write() -### Writable event handler. Concrete deriviatives of Danga::Socket may wish to -### provide an implementation of this. The default implementation calls -### C with an C. -sub event_write { - my $self = shift; - $self->write(undef); -} - - -### METHOD: watch_read( $boolean ) -### Turn 'readable' event notification on or off. -sub watch_read { - my Danga::Socket $self = shift; - return if $self->{closed} || !$self->{sock}; - - my $val = shift; - my $event = $self->{event_watch}; - - $event &= ~POLLIN if ! $val; - $event |= POLLIN if $val; - - # If it changed, set it - if ($event != $self->{event_watch}) { - if ($HaveKQueue) { - $KQueue->EV_SET($self->{fd}, IO::KQueue::EVFILT_READ(), - $val ? IO::KQueue::EV_ENABLE() : IO::KQueue::EV_DISABLE()); - } - elsif ($HaveEpoll) { - epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) - and $self->dump_error("couldn't modify epoll settings for $self->{fd} " . - "from $self->{event_watch} -> $event: $! (" . ($!+0) . ")"); - } - $self->{event_watch} = $event; - } -} - -### METHOD: watch_write( $boolean ) -### Turn 'writable' event notification on or off. -sub watch_write { - my Danga::Socket $self = shift; - return if $self->{closed} || !$self->{sock}; - - my $val = shift; - my $event = $self->{event_watch}; - - $event &= ~POLLOUT if ! $val; - $event |= POLLOUT if $val; - - # If it changed, set it - if ($event != $self->{event_watch}) { - if ($HaveKQueue) { - $KQueue->EV_SET($self->{fd}, IO::KQueue::EVFILT_WRITE(), - $val ? IO::KQueue::EV_ENABLE() : IO::KQueue::EV_DISABLE()); - } - elsif ($HaveEpoll) { - epoll_ctl($Epoll, EPOLL_CTL_MOD, $self->{fd}, $event) - and $self->dump_error("couldn't modify epoll settings for $self->{fd} " . - "from $self->{event_watch} -> $event: $! (" . ($!+0) . ")"); - } - $self->{event_watch} = $event; - } -} - -# METHOD: dump_error( $message ) -# Prints to STDERR a backtrace with information about this socket and what lead -# up to the dump_error call. -sub dump_error { - my $i = 0; - my @list; - while (my ($file, $line, $sub) = (caller($i++))[1..3]) { - push @list, "\t$file:$line called $sub\n"; - } - - warn "ERROR: $_[1]\n" . - "\t$_[0] = " . $_[0]->as_string . "\n" . - join('', @list); -} - - -### METHOD: debugmsg( $format, @args ) -### Print the debugging message specified by the C-style I and -### I if the object's C is greater than or equal to the given -### I. -sub debugmsg { - my ( $self, $fmt, @args ) = @_; - confess "Not an object" unless ref $self; - - chomp $fmt; - printf STDERR ">>> $fmt\n", @args; -} - - -### METHOD: peer_ip_string() -### Returns the string describing the peer's IP -sub peer_ip_string { - my Danga::Socket $self = shift; - return _undef("peer_ip_string undef: no sock") unless $self->{sock}; - return $self->{peer_ip} if defined $self->{peer_ip}; - - my $pn = getpeername($self->{sock}); - return _undef("peer_ip_string undef: getpeername") unless $pn; - - my ($port, $iaddr) = Socket::sockaddr_in($pn); - $self->{peer_port} = $port; - - return $self->{peer_ip} = Socket::inet_ntoa($iaddr); -} - -### METHOD: peer_addr_string() -### Returns the string describing the peer for the socket which underlies this -### object in form "ip:port" -sub peer_addr_string { - my Danga::Socket $self = shift; - my $ip = $self->peer_ip_string; - return $ip ? "$ip:$self->{peer_port}" : undef; -} - -### METHOD: local_ip_string() -### Returns the string describing the local IP -sub local_ip_string { - my Danga::Socket $self = shift; - return _undef("local_ip_string undef: no sock") unless $self->{sock}; - return $self->{local_ip} if defined $self->{local_ip}; - - my $pn = getsockname($self->{sock}); - return _undef("local_ip_string undef: getsockname") unless $pn; - - my ($port, $iaddr) = Socket::sockaddr_in($pn); - $self->{local_port} = $port; - - return $self->{local_ip} = Socket::inet_ntoa($iaddr); -} - -### METHOD: local_addr_string() -### Returns the string describing the local end of the socket which underlies this -### object in form "ip:port" -sub local_addr_string { - my Danga::Socket $self = shift; - my $ip = $self->local_ip_string; - return $ip ? "$ip:$self->{local_port}" : undef; -} - - -### METHOD: as_string() -### Returns a string describing this socket. -sub as_string { - my Danga::Socket $self = shift; - my $rw = "(" . ($self->{event_watch} & POLLIN ? 'R' : '') . - ($self->{event_watch} & POLLOUT ? 'W' : '') . ")"; - my $ret = ref($self) . "$rw: " . ($self->{closed} ? "closed" : "open"); - my $peer = $self->peer_addr_string; - if ($peer) { - $ret .= " to " . $self->peer_addr_string; - } - return $ret; -} - -sub _undef { - return undef unless $ENV{DS_DEBUG}; - my $msg = shift || ""; - warn "Danga::Socket: $msg\n"; - return undef; -} - -1; - -# Local Variables: -# mode: perl -# c-basic-indent: 4 -# indent-tabs-mode: nil -# End: