half baked version of the new object mail engine

(note the branch, v010)


git-svn-id: https://svn.perl.org/qpsmtpd/branches/v010@23 958fd67b-6ff1-0310-b445-bb7760255be9

lib/Qpsmtpd.pm

@@ -0,0 +1,250 @@
+package Qpsmtpd;
+use strict;
+use Carp;
+
+use Qpsmtpd::Connection;
+use Qpsmtpd::Transaction;
+use Qpsmtpd::Constants;
+
+use Mail::Address ();
+use Sys::Hostname;
+use IPC::Open2;
+use Data::Dumper;
+BEGIN{$^W=0;}
+use Net::DNS;
+BEGIN{$^W=1;}
+
+$Qpsmtpd::VERSION = "0.10-dev";
+
+# $SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit };
+
+
+sub new {
+  my $proto = shift;
+  my $class = ref($proto) || $proto;
+
+  my %args = @_;
+
+  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;
+  # this list of valid commands should probably be a method or a set of methods
+  $self->{_commands} = \%commands;
+
+  $self;
+}
+
+
+#
+# method to get the configuration.  It just calls get_qmail_config by
+# default, but it could be overwritten to look configuration up in a
+# database or whatever.
+#
+sub config {
+  my ($self, $c) = @_;
+
+  my %defaults = (
+		  me      => hostname,
+		  timeout => 1200,
+		  );
+
+  return ($self->get_qmail_config($c) || $defaults{$c} || undef);
+
+};
+
+sub log {
+  my ($self, $trace, @log) = @_;
+  warn join(" ", $$, @log), "\n"
+    if $trace <= 10;
+}
+
+sub dispatch {
+  my $self = shift;
+  my ($cmd) = lc shift;
+
+  warn "command: $cmd";
+
+  #$self->respond(553, $state{dnsbl_blocked}), return 1
+  #  if $state{dnsbl_blocked} and ($cmd eq "rcpt");
+
+  $self->respond(500, "Unrecognized command"), return 1
+    if ($cmd !~ /^(\w{1,12})$/ or !exists $self->{_commands}->{$1});
+  $cmd = $1;
+
+  if (1 or $self->{_commands}->{$cmd} and $self->can($cmd)) {
+    my ($result) = eval { $self->$cmd(@_) };
+    $self->log(0, "XX: $@") if $@;
+    return $result if defined $result;
+    return $self->fault("command '$cmd' failed unexpectedly");
+  }
+
+  return;
+}
+
+sub fault {
+  my $self = shift;
+  my ($msg) = shift || "program fault - command not performed";
+  print STDERR "$0[$$]: $msg ($!)\n";
+  return $self->respond(451, "Internal error - try again later - " . $msg);
+}
+
+
+sub start_conversation {
+    my $self = shift;
+    $self->respond(220, $self->config('me') ." qpsmtpd ". $self->version ." Service ready, send me all your stuff!");
+}
+
+sub transaction {
+  my $self = shift;
+  use Data::Dumper;
+  warn Data::Dumper->Dump([\$self], [qw(self)]);
+  return $self->{_transaction} || ($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) = @_;
+  my $conn = $self->connection;
+  return $self->respond (503, "but you already said HELO ...") if $conn->hello;
+
+  $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.");
+}
+
+sub ehlo {
+  my ($self, $hello_host, @stuff) = @_;
+  my $conn = $self->connection;
+  return $self->respond (503, "but you already said HELO ...") if $conn->hello;
+
+  $conn->hello("ehlo");
+  $conn->hello_host($hello_host);
+  $self->transaction;
+
+  $self->respond(250,
+		 $self->config("me") . " Hi " . $conn->remote_info . " [" . $conn->remote_ip ."]",
+		 "PIPELINING",
+		 "8BITMIME",
+		 ($self->config('databytes') ? "SIZE ". ($self->config('databytes'))[0] : ()),
+		);
+}
+
+sub mail {
+  my $self = shift;
+  return $self->respond(501, "syntax error in parameters") if $_[0] !~ m/^from:/i;
+  unless ($self->connection->hello) {
+    return $self->respond(503, "please say hello first ...");
+  }
+  else {
+    my $from_parameter = join " ", @_;
+    $self->log(2, "full from_parameter: $from_parameter");
+    my ($from) = ($from_parameter =~ m/^from:\s*(\S+)/i)[0];
+    #warn "$$ from email address : $from\n" if $TRACE;
+    if ($from eq "<>" or $from =~ m/\[undefined\]/) {
+      $from = Mail::Address->new("<>");
+    } 
+    else {
+      $from = (Mail::Address->parse($from))[0];
+    }
+    return $self->respond(501, "could not parse your mail from command") unless $from;
+
+    # this needs to be moved to a plugin --- FIXME
+    0 and $from->format ne "<>"
+      and $self->config("require_resolvable_fromhost")
+      and !check_dns($from->host)
+      and return $self->respond(450, $from->host ? "Could not resolve ". $from->host : "FQDN required in the envelope sender");
+
+    $self->log(2, "getting mail from ".$from->format);
+    $self->respond(250, $from->format . ", sender OK - I always like getting mail from you!");
+
+    $self->transaction->sender($from);
+  }
+}
+
+sub rcpt {
+  my $self = shift;
+  return $self->respond(501, "syntax error in parameters") unless $_[0] =~ m/^to:/i;
+  return(503, "Use MAIL before RCPT") unless $self->transaction->sender;
+
+  my $from = $self->transaction->sender;
+
+  # Move to a plugin -- FIXME
+  if (0 and $from->format ne "<>" and $self->config('rhsbl_zones')) {
+    my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->config('rhsbl_zones');
+    my $host = $from->host;
+    for my $rhsbl (keys %rhsbl_zones) {
+      $self->respond("550", "Mail from $host rejected because it $rhsbl_zones{$rhsbl}"), return 1
+	if check_rhsbl($rhsbl, $host);
+    }
+  }
+
+  my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0];
+  $rcpt = $_[1] unless $rcpt;
+  $rcpt = (Mail::Address->parse($rcpt))[0];
+  return $self->respond(501, "could not parse recipient") unless $rcpt;
+  return $self->respond(550, "will not relay for ". $rcpt->host) unless $self->check_relay($rcpt->host);
+  $self->transaction->add_recipient($rcpt);
+  $self->respond(250, $rcpt->format . ", recipient OK");
+}
+
+ 
+sub check_relay {
+  my $self = shift;
+  my $host = lc shift;
+  my @rcpt_hosts = $self->config("rcpthosts");
+  return 1 if exists $ENV{RELAYCLIENT};
+  for my $allowed (@rcpt_hosts) {
+    $allowed =~ s/^\s*(\S+)/$1/;
+    return 1 if $host eq lc $allowed;
+    return 1 if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i;
+  }
+  return 0;
+}
+
+sub get_qmail_config {
+  my ($self, $config) = (shift, shift);
+  $self->log(5, "trying to get config for $config");
+  if ($self->{_config_cache}->{$config}) {
+    return wantarray ? @{$self->{_config_cache}->{$config}} : $self->{_config_cache}->{$config}->[0];
+  }
+  my $configdir = '/var/qmail/control';
+  my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
+  $configdir = "$name/config" if (-e "$name/config/$config");
+  open CF, "<$configdir/$config" or warn "$$ could not open configfile $config: $!", return;
+  my @config = <CF>;
+  chomp @config;
+  @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/} @config;
+  close CF;
+  $self->log(5, "returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
+  $self->{_config_cache}->{$config} = \@config;
+  return wantarray ? @config : $config[0];
+}
+
+
+sub help {
+  my $self = shift;
+  $self->respond(214, 
+	  "This is qpsmtpd " . $self->version,
+	  "See http://develooper.com/code/qpsmtpd/",
+	  'To report bugs or send comments, mail to <ask@perl.org>.');
+}
+
+sub version {
+  $Qpsmtpd::VERSION;
+}
+
+sub quit {
+  my $self = shift;
+  $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day");
+  exit;
+}
+
+
+1;

lib/Qpsmtpd/Connection.pm

@@ -0,0 +1,55 @@
+package Qpsmtpd::Connection;
+use strict;
+
+sub new {
+  my $proto = shift;
+  my $class = ref($proto) || $proto;
+  my $self = {};
+  bless ($self, $class);
+}
+
+sub start {
+  my $self = shift;
+  $self = $self->new(@_) unless ref $self;
+
+  my %args = @_;
+
+  for my $f (qw(remote_host remote_ip remote_info)) {
+    $self->$f($args{$f}) if $args{$f};
+  }
+
+  return $self;
+}
+
+sub remote_host {
+  my $self = shift;
+  @_ and $self->{_remote_host} = shift;
+  $self->{_remote_host};
+}
+
+sub remote_ip {
+  my $self = shift;
+  @_ and $self->{_remote_ip} = shift;
+  $self->{_remote_ip};
+}
+
+sub remote_info {
+  my $self = shift;
+  @_ and $self->{_remote_info} = shift;
+  $self->{_remote_info};
+}
+
+sub hello {
+  my $self = shift;
+  @_ and $self->{_hello} = shift;
+  $self->{_hello};
+}
+
+sub hello_host {
+  my $self = shift;
+  @_ and $self->{_hello_host} = shift;
+  $self->{_hello_host};
+}
+
+
+1;

lib/Qpsmtpd/Constants.pm

@@ -0,0 +1,6 @@
+package Qpsmtpd::Constants;
+use strict;
+use constant TRACE => 10;
+
+
+1;

lib/Qpsmtpd/TcpServer.pm

@@ -0,0 +1,52 @@
+package Qpsmtpd::TcpServer;
+use strict;
+use base qw(Qpsmtpd);
+
+sub start_connection {
+    my $self = shift;
+
+    my $remote_host = $ENV{TCPREMOTEHOST} || "[$ENV{TCPREMOTEIP}]";
+    my $remote_info = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
+    my $remote_ip   = $ENV{TCPREMOTEIP};
+
+    $self->SUPER::connection->start(remote_info => $remote_info,
+				    remote_ip   => $remote_ip,
+				    remote_host => $remote_host,
+				    @_);
+}
+
+sub run {
+    my $self = shift;
+
+    $self->start_conversation;
+
+    # this should really be the loop and read_input should just get one line; I think
+    
+    $self->read_input;
+}
+
+sub read_input {
+  my $self = shift;
+  alarm $self->config('timeout');
+  while (<STDIN>) {
+    alarm 0;
+    $_ =~ s/\r?\n$//s; # advanced chomp
+    $self->log(1, "dispatching $_");
+    defined $self->dispatch(split / +/, $_)
+      or $self->respond(502, "command unrecognized: '$_'");
+    alarm $self->config('timeout');
+  }
+}
+
+sub respond {
+  my ($self, $code, @messages) = @_;
+  while (my $msg = shift @messages) {
+    my $line = $code . (@messages?"-":" ").$msg;
+    $self->log(1, "$line");
+    print "$line\r\n" or ($self->log("Could not print [$line]: $!"), return 0);
+  }
+  return 1;
+}
+
+
+1;

lib/Qpsmtpd/Transaction.pm

@@ -0,0 +1,30 @@
+package Qpsmtpd::Transaction;
+use strict;
+
+sub new { start(@_) }
+
+sub start {
+  my $proto = shift;
+  my $class = ref($proto) || $proto;
+  my %args = @_;
+  my $self = { _rcpt => [] };
+  bless ($self, $class);
+}
+
+sub add_header {
+  my $self = shift;
+}
+
+sub add_recipient {
+  my $self = shift;
+
+}
+
+sub sender {
+  my $self = shift;
+  @_ and $self->{_sender} = shift;
+  $self->{_sender};
+
+}
+
+1;

qpsmtpd

@@ -10,169 +10,23 @@
 #
 #
 
-package QPsmtpd;
+use lib 'lib';
-$QPsmtpd::VERSION = "0.07b";
+use Qpsmtpd::TcpServer;
 use strict;
 $| = 1;
-use Mail::Address ();
-use Sys::Hostname;
-use IPC::Open2;
-use Data::Dumper;
-BEGIN{$^W=0;}
-use Net::DNS;
-BEGIN{$^W=1;}
 
 delete $ENV{ENV};
 $ENV{PATH} = '/var/qmail/bin';
 
 use vars qw($TRACE);
+$TRACE = 5;
 
-$TRACE = 0;
+# should this be ->new ?
+my $qpsmtpd = Qpsmtpd::TcpServer->new();
+$qpsmtpd->start_connection();
+$qpsmtpd->run();
 
-my %config;
+__END__
-$config{me} = get_config('me') || hostname;
-$config{timeout} = get_config('timeoutsmtpd') || 1200;
-
-my (@commands) = qw(ehlo helo rset mail rcpt data help vrfy noop quit);
-my (%commands); @commands{@commands} = ('') x @commands;
-
-my %state;
-
-respond(220, "$config{me} qpsmtpd $QPsmtpd::VERSION Service ready, send me all your stuff!");
-
-my $remote_host = $ENV{TCPREMOTEHOST} || "[$ENV{TCPREMOTEIP}]";
-$state{remote_info} = $ENV{TCPREMOTEINFO} ? "$ENV{TCPREMOTEINFO}\@$remote_host" : $remote_host;
-$state{remote_ip} = $ENV{TCPREMOTEIP};
-
-$SIG{ALRM} = sub { respond(421, "Game over pal, game over. You got a timeout; I just can't wait that long..."); exit };
-
-$state{dnsbl_blocked} = check_dnsbl($state{remote_ip});
-
-my ($commands) = '';
-alarm $config{timeout};
-while (<STDIN>) {
-  alarm 0;
-  $_ =~ s/\r?\n$//s; # advanced chomp
-  warn "$$ dispatching $_\n" if $TRACE;
-  defined dispatch(split / +/, $_)
-    or respond(502, "command unrecognized: '$_'");
-  alarm $config{timeout};
-}
-
-sub dispatch {
-  my ($cmd) = lc shift;
-
-  respond(553, $state{dnsbl_blocked}), return 1
-    if $state{dnsbl_blocked} and ($cmd eq "rcpt");
-
-  respond(500, "Unrecognized command"), return 1
-    if ($cmd !~ /^(\w{1,12})$/ or !exists $commands{$1});
-  $cmd = $1;
-
-
-  if (exists $commands{$cmd}) {
-    my ($result) = eval "&$cmd";
-    warn "$$ $@" if $@;
-    return $result if defined $result;
-    return fault("command '$cmd' failed unexpectedly");
-  }
-
-  return;
-}
-
-sub respond {
-  my ($code, @messages) = @_;
-  while (my $msg = shift @messages) {
-    my $line = $code . (@messages?"-":" ").$msg;
-    print "$line\r\n";
-    warn "$$ $line\n" if $TRACE;
-  }
-  return 1;
-}
-
-sub fault {
-  my ($msg) = shift || "program fault - command not performed";
-  print STDERR "$0[$$]: $msg ($!)\n";
-  return respond(451, "Internal error - try again later - " . $msg);
-}
-
-sub helo {
-  my ($hello_host, @stuff) = @_;
-  return respond (503, "but you already said HELO ...") if $state{hello};
-  $state{hello} = "helo";
-  $state{hello_host} = $hello_host;
-  $state{transaction} = {};
-  respond(250, "$config{me} Hi $state{remote_info} [$state{remote_ip}]; I am so happy to meet you.");
-}
-
-sub ehlo {
-  my ($hello_host, @stuff) = @_;
-  return respond (503, "but you already said HELO ...") if $state{hello};
-  $state{hello} = "ehlo";
-  $state{hello_host} = $hello_host;
-  $state{transaction} = {};
-  respond(250,
-	  "$config{me} Hi $state{remote_info} [$state{remote_ip}].",
-	  "PIPELINING",
-	  "8BITMIME",
-	  (get_config('databytes') ? "SIZE ". (get_config('databytes'))[0] : ()),
-	 );
-}
-
-
-sub mail {
-  return respond(501, "syntax error in parameters") if $_[0] !~ m/^from:/i;
-  unless ($state{hello}) {
-    return respond(503, "please say hello first ...");
-  }
-  else {
-    my $from_parameter = join " ", @_;
-    warn "$$ full from_parameter: $from_parameter\n" if $TRACE;
-    my ($from) = ($from_parameter =~ m/^from:\s*(\S+)/i)[0];
-    #warn "$$ from email address : $from\n" if $TRACE;
-    if ($from eq "<>" or $from =~ m/\[undefined\]/) {
-      $from = Mail::Address->new("<>");
-    } 
-    else {
-      $from = (Mail::Address->parse($from))[0];
-    }
-    return respond(501, "could not parse your mail from command") unless $from;
-
-    $from->format ne "<>"
-      and get_config("require_resolvable_fromhost")
-      and !check_dns($from->host)
-      and return respond(450, $from->host ? "Could not resolve ". $from->host : "FQDN required in the envelope sender");
-
-    warn "$$ getting mail from ",$from->format,"\n" if $TRACE;
-    respond(250, $from->format . ", sender OK - I always like getting mail from you!");
-
-    $state{transaction} = { from => $from };
-  }
-}
-
-sub rcpt {
-  return respond(501, "syntax error in parameters") unless $_[0] =~ m/^to:/i;
-  return(503, "Use MAIL before RCPT") unless $state{transaction}->{from};
-
-  my $from = $state{transaction}->{from};
-  if ($from->format ne "<>" and get_config('rhsbl_zones')) {
-    my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } get_config('rhsbl_zones');
-    my $host = $from->host;
-    for my $rhsbl (keys %rhsbl_zones) {
-      respond("550", "Mail from $host rejected because it $rhsbl_zones{$rhsbl}"), return 1
-	if check_rhsbl($rhsbl, $host);
-    }
-  }
-
-
-  my ($rcpt) = ($_[0] =~ m/to:(.*)/i)[0];
-  $rcpt = $_[1] unless $rcpt;
-  $rcpt = (Mail::Address->parse($rcpt))[0];
-  return respond(501, "could not parse recipient") unless $rcpt;
-  return respond(550, "will not relay for ". $rcpt->host) unless check_relay($rcpt->host);
-  push @{$state{transaction}->{rcpt}}, $rcpt;
-  respond(250, $rcpt->format . ", recipient OK");
-}
 
 sub data {
   respond(503, "MAIL first"), return 1 unless $state{transaction}->{from};
@@ -300,17 +154,6 @@ sub vrfy {
   respond(252, "Just try sending a mail and we'll see how it turns out ...");
 }
 
-sub help {
-  respond(214, 
-	  "This is qpsmtpd $QPsmtpd::VERSION",
-	  "See http://develooper.com/code/qpsmtpd/",
-	  "To report bugs or whatnot, send mail to <ask\@perl.org>.");
-}
-
-sub quit {
-  respond(221, "$config{me} closing connection. Have a wonderful day");
-  exit;
-}
 
 sub check_rhsbl {
   my ($rhsbl, $host) = @_;
@@ -320,36 +163,6 @@ sub check_rhsbl {
   return 0;
 }
 
-sub check_dnsbl {
-  my ($ip, $debug) = @_;
-  local $TRACE = 5 if $debug;
-  my %dnsbl_zones = map { (split /\s+/, $_, 2)[0,1] } get_config('dnsbl_zones');
-  return unless %dnsbl_zones;
-  
-  my $reversed_ip = join(".", reverse(split(/\./, $ip)));
-
-  my $res = new Net::DNS::Resolver;
-  for my $dnsbl (keys %dnsbl_zones) {
-    warn "$$ Checking $reversed_ip.$dnsbl ..." if $TRACE > 2;
-    my $query = $res->query("$reversed_ip.$dnsbl", "TXT");
-    if ($query) {
-      my $a_record = 0;
-      foreach my $rr ($query->answer) {
-	$a_record = 1 if $rr->type eq "A";
-	next unless $rr->type eq "TXT";
-	warn "got txt record" if $TRACE > 9;
-	return $rr->txtdata;
-      }
-      return "Blocked by $dnsbl" if $a_record;
-    }
-    else {
-      warn "$$ query for $reversed_ip.$dnsbl failed: ", $res->errorstring, "\n"
-	unless $res->errorstring eq "NXDOMAIN";
-    }
-  }
-  return "";
-}
-
 sub check_dns {
   my $host = shift;
 
@@ -374,34 +187,12 @@ sub check_dns {
 }
 
 
-sub check_relay {
+sub load_plugins {
-  my $host = lc shift;
+  my @plugins = get_config('plugins');
-  my @rcpt_hosts = get_config("rcpthosts");
-  return 1 if exists $ENV{RELAYCLIENT};
-  for my $allowed (@rcpt_hosts) {
-    $allowed =~ s/^\s*(\S+)/$1/;
-    return 1 if $host eq lc $allowed;
-    return 1 if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i;
-  }
-  return 0;
-}
 
-my %config_cache;
-sub get_config {
-  my $config = shift;
-  warn "$$ trying to get config for $config" if $TRACE > 4;
-  return @{$config_cache{$config}} if $config_cache{$config};
-  my $configdir = '/var/qmail/control';
   my ($name) = ($0 =~ m!(.*?)/([^/]+)$!);
-  $configdir = "$name/config" if (-e "$name/config/$config");
+  my $dir = "$name/plugins";
-  open CF, "<$configdir/$config" or warn "$$ could not open configfile $config: $!", return;
+  warn "$$ loading plugins from $dir" if $TRACE;
-  my @config = <CF>;
-  chomp @config;
-  @config = grep { $_ and $_ !~ m/\s*#/ } @config;
-  close CF;
-  warn "$$ returning get_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]) if $TRACE > 4;
-  $config_cache{$config} = \@config;
-  return wantarray ? @config : $config[0];
 }
 
 1;

run

@@ -3,6 +3,6 @@ QMAILDUID=`id -u smtpd`
 NOFILESGID=`id -g smtpd`
 exec /usr/local/bin/softlimit -m 10000000 \
   /usr/local/bin/tcpserver -c 10 -v -p \
-  -u $QMAILDUID -g $NOFILESGID 0 smtp \
+  -u $QMAILDUID -g $NOFILESGID 64.81.84.165 smtp \
   ./qpsmtpd 2>&1