yay, plugin support works! :-D

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

README.plugins

@@ -0,0 +1,87 @@
+#
+# read this with 'perldoc README.plugins'  ...
+#
+
+=head1 qpsmtpd plugin system; developer documentation
+
+See the examples in plugins/ and ask questions on the qpsmtpd
+mailinglist; subscribe by sending mail to qpsmtpd-subscribe@perl.org.
+
+=head1 General return codes
+
+Each plugin must return an allowed constant for the hook and (usually)
+optionally a "message".
+
+Generally all plugins for a hook are processed until one returns
+something other than "DECLINED".
+
+Plugins are run in the order they are listed in the "plugins"
+configuration.
+
+=over 4
+
+=item OK
+
+Action allowed
+
+=item DENY
+
+Action denied
+
+=item DENYSOFT
+
+Action denied; return a temporary rejection code (say 450 instead of 550).
+
+=item DECLINED
+
+Plugin declined work; proceed as usual.  This return code is always
+allowed unless noted otherwise.
+
+=item DONE
+
+Finishing processing of the request.  Usually used when the plugin
+sent the response to the client.
+
+=back
+
+See more detailed description for each hook below.
+
+=head1 Hooks
+
+=head2 mail
+
+Called right after the envelope sender address is passed.  The plugin
+gets passed a Mail::Address object.  Default is to allow the
+recipient.
+
+Allowed return codes
+
+  OK       - sender allowed
+  DENY     - Return a hard failure code
+  DENYSOFT - Return a soft failure code
+  DONE     - skip further processing
+
+
+=head2 rcpt
+
+Hook for the "rcpt" command.  Defaults to deny the mail with a soft
+error code.
+
+Allowed return codes
+
+  OK       - recipient allowed
+  DENY     - Return a hard failure code
+  DENYSOFT - Return a soft failure code
+  DONE     - skip further processing
+
+
+=head2 quit
+
+Called on the "quit" command.
+
+Allowed return codes:
+
+  DONE 
+
+All other codes will qpsmtpd do the default response.
+

STATUS

@@ -2,29 +2,40 @@
 things to do for v0.10
 ----------------------
 
-transaction should probably be a part of the connection object instead
+transaction should maybe be a part of the connection object instead
 of off the main object
 
-get timeouts to work in "tcpserver" mode (or generally...)
+get timeouts to work in "tcpserver" mode (or generally; not sure where
+it fits best)
 
 
 plugin support;
 
-  load plugins in a funny namespace
-  let them register the "hooks" they want to run in
+  support plugins for the rest of the commands.
+
+  specify a priority in register_hook. ("LAST", "FIRST", "MIDDLE", or
+  maybe a number)
+
+  proper access to the message body through the transaction
 
 
 data command
   
-  how to spool the file?
+  how to spool message to a file when it grows large and still give
+  reasonable easy access to the data from plugins?
 
 ... 
 
 
-
-TRACE in Constants.pm is not actually being used.
+TRACE in Constants.pm is not actually being used.  Should it?
 
 
 
-Plugin Documentation!
+Future Ideas
+============
 
+Methods to create a bounce message easily; partly so we can accept a
+mail for one user but bounce it right away for another RCPT'er.
+
+David Carraway has some thoughts for "user filters"
+http://nntp.perl.org/group/perl.qpsmtpd/2

config.sample/IP

@@ -1,4 +1,4 @@
-0 
+64.81.84.165
 # the first line of this file is being used as the IP 
 # address tcpserver will bind to.  Use 0 to bind to all
 # interfaces.

config.sample/plugins

@@ -1,3 +1,7 @@
 quit_fortune
+require_resolvable_fromhost
+rhsbl
 # dnsbl
 
+# this plugin needs to run after all other "rcpt" plugins
+check_relay

config.sample/rhsbl_zones

@@ -2,3 +2,4 @@ dsn.rfc-ignorant.org does not accept bounces. This violates RFC 821/2505/2821 ht
 
 
 
+

lib/Qpsmtpd.pm

@@ -72,8 +72,6 @@ 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");
 
@@ -164,59 +162,61 @@ sub mail {
     }
     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");
-
+    my ($rc, $msg) = $self->run_hooks("mail", $from);
+    if ($rc == DONE) {
+      return 1;
+    }
+    elsif ($rc == DENY) {
+      $msg ||= $from->format . ', denied';
+      $self->log(2, "deny mail from " . $from->format . " ($msg)");
+      $self->respond(550, $msg);
+    }
+    elsif ($rc == DENYSOFT) {
+      $msg ||= $from->format . ', temporarily denied';
+      $self->log(2, "denysoft mail from " . $from->format . " ($msg)");
+      $self->respond(450, $msg);
+    }
+    else { # includes OK
       $self->log(2, "getting mail from ".$from->format);
       $self->respond(250, $from->format . ", sender OK - how exciting to get 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");
+
+  my ($rc, $msg) = $self->run_hooks("rcpt", $rcpt);
+  if ($rc == DONE) {
+    return 1;
   }
-
- 
-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;
+  elsif ($rc == DENY) {
+    $msg ||= 'relaying denied';
+    $self->respond(550, $msg);
+  }
+  elsif ($rc == DENYSOFT) {
+    $msg ||= 'relaying denied';
+    return $self->respond(550, $msg);
+  }
+  elsif ($rc == OK) {
+    $self->respond(250, $rcpt->format . ", recipient ok");
+    return $self->transaction->add_recipient($rcpt);
+  }
+  else {
+    return $self->respond(450, "Could not determine of relaying is allowed");
   }
   return 0;
 }
 
+
 sub get_qmail_config {
   my ($self, $config) = (shift, shift);
   $self->log(5, "trying to get config for $config");
@@ -269,9 +269,10 @@ sub rset {
 
 sub quit {
   my $self = shift;
-  my @fortune = `/usr/games/fortune -s`;
-  @fortune = map { chop; s/^/  \/ /; $_ } @fortune;
-  $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day.", @fortune);
+  my ($rc, $msg) = $self->run_hooks("quit");
+  if ($rc != DONE) {
+    $self->respond(221, $self->config('me') . " closing connection. Have a wonderful day.");
+  }
   exit;
 }
 
@@ -449,37 +450,57 @@ sub load_plugins {
     my $eval = join(
 		    "\n",
 		    "package $package;",
+		    'use Qpsmtpd::Constants;',
 		    "require Qpsmtpd::Plugin;",
 		    'use vars qw(@ISA);',
 		    '@ISA = qw(Qpsmtpd::Plugin);',
-#		    $line,
+		    $line,
 		    $sub,
 		    "\n", # last line comment without newline?
 		   );
 
     warn "eval: $eval";
 
-    $eval =~ m/(.*)/;
+    $eval =~ m/(.*)/s;
     $eval = $1;
 
     eval $eval;
     warn "EVAL: $@";
     die "eval $@" if $@;
 
-    #my $package_path = $package;
-    #$package_path =~ s!::!/!g;
-    #$package_path .= ".pm";
-    #$INC{$package_path} = "$dir/$plugin";
-    #use Data::Dumper;
-    #warn Data::Dumper->Dump([\%INC, \@INC], [qw(INCh INCa)]);
-
-    my $plug = $package->new();
-    $plug->register();
+    my $plug = $package->new(qpsmtpd => $self);
+    $plug->register($self);
 
   }
-
 }
 
+sub run_hooks {
+  my ($self, $hook) = (shift, shift);
+  if ($self->{_hooks}->{$hook}) {
+    my @r;
+    for my $code (@{$self->{_hooks}->{$hook}}) {
+      (@r) = &{$code}($self->transaction, @_);
+      last unless $r[0] == DECLINED; 
+    }
+    return @r;
+  }
+  warn "Did not run any hooks ...";
+  return (0, '');
+}
+
+sub _register_hook {
+  my $self = shift;
+  my ($hook, $code) = @_;
+
+  #my $plugin = shift;  # see comment in Plugin.pm:register_hook
+
+  $self->{_hooks} ||= {};
+  my $hooks = $self->{_hooks};
+  push @{$hooks->{$hook}}, $code;
+}
+
+
+
 
 
 1;

lib/Qpsmtpd/Constants.pm

@@ -1,7 +1,21 @@
 package Qpsmtpd::Constants;
 use strict;
+require Exporter;
+
+my (@common) = qw(OK DECLINED DONE DENY DENYSOFT TRACE);
+
+use vars qw($VERSION @ISA @EXPORT);
+@ISA    = qw(Exporter);
+@EXPORT = @common;
+
 use constant TRACE => 10;
 
+use constant OK       => 900;
+use constant DENY     => 901;
+use constant DENYSOFT => 902;
+use constant DECLINED => 909;
+use constant DONE     => 910;
+
 
 1;
 

lib/Qpsmtpd/Plugin.pm

@@ -4,14 +4,28 @@ use strict;
 sub new {
   my $proto = shift;
   my $class = ref($proto) || $proto;
-  bless ({}, $class);
+  my %args = @_;
+  bless ({ _qp => $args{qpsmtpd} }, $class);
 }
 
-
-
 sub register_hook {
-  warn "REGISTER HOOK!";
+  my ($plugin, $hook, $method) = @_;
+  # 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.
+  $plugin->qp->_register_hook($hook, sub { $plugin->$method(@_) });
 }
 
+sub qp {
+  shift->{_qp};
+}
+
+sub log {
+    shift->qp->log(@_);
+}
+
+sub transaction {
+  # not sure if this will work in a non-forking or a threaded daemon
+  shift->qp->transaction;
+}
 
 1;

lib/Qpsmtpd/Transaction.pm

@@ -45,6 +45,12 @@ sub blocked {
   $self->{_blocked};
 }
 
+sub notes {
+  my $self = shift;
+  my $key  = shift;
+  @_ and $self->{_notes}->{$key} = shift;
+  $self->{_notes}->{$key};
+}
 
 #sub add_header_line {
 #}

plugins/check_relay

@@ -0,0 +1,23 @@
+# this plugin checks the standard rcpthosts config and
+# $ENV{RELAYCLIENT} to see if relaying is allowed.
+#
+# It should be configured to be run _LAST_!
+#
+
+sub register {
+  my ($self, $qp) = @_;
+  $self->register_hook("rcpt", "check_relay");
+}
+
+sub check_relay {
+  my ($self, $transaction, $recipient) = @_;
+  my $host = lc $recipient->host;
+  my @rcpt_hosts = $self->qp->config("rcpthosts");
+  return (OK) if exists $ENV{RELAYCLIENT};
+  for my $allowed (@rcpt_hosts) {
+    $allowed =~ s/^\s*(\S+)/$1/;
+    return (OK) if $host eq lc $allowed;
+    return (OK) if substr($allowed,0,1) eq "." and $host =~ m/\Q$allowed\E$/i;
+  }
+  return (DENY);
+}

plugins/quit_fortune

@@ -1,14 +1,12 @@
 
-sub new {}
-
 sub register {
-  my ($self, $qp) = @_;
-
-  $qp->register_hook("quit", "quit_handler");
-
+  shift->register_hook("quit", "quit_handler");
 }
 
 sub quit_handler {
-  my ($self, $qp) = @_;
-
+  my $qp = shift->qp;
+  my @fortune = `/usr/games/fortune -s`;
+  @fortune = map { chop; s/^/  \/ /; $_ } @fortune;
+  $qp->respond(221, $qp->config('me') . " closing connection.", @fortune);
+  return DONE;
 }

plugins/require_resolvable_fromhost

@@ -0,0 +1,46 @@
+use Net::DNS qw(mx);
+
+sub register {
+  my ($self, $qp) = @_;
+  $self->register_hook("mail", "mail_handler");
+}
+
+sub mail_handler {
+  my ($self, $transaction, $sender) = @_;
+   
+  $sender->format ne "<>"
+    and $self->qp->config("require_resolvable_fromhost")
+    and !check_dns($sender->host)
+    and return (DENYSOFT, 
+		($sender->host
+		   ? "Could not resolve ". $sender->host
+		   : "FQDN required in the envelope sender"));
+  
+   return DECLINED;
+
+}
+
+
+sub check_dns {
+  my $host = shift;
+
+  # 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;
+  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 {
+    warn "$$ query for $host failed: ", $res->errorstring, "\n"
+      unless $res->errorstring eq "NXDOMAIN";
+  }
+  return 0;
+}
+

plugins/rhsbl

@@ -0,0 +1,37 @@
+
+sub register {
+  my ($self, $qp) = @_;
+  $self->register_hook("mail", "mail_handler");
+  $self->register_hook("rcpt", "rcpt_handler");
+}
+
+sub mail_handler {
+  my ($self, $transaction, $sender) = @_;
+  # lookup the address here; but always just return DECLINED
+  if ($sender->format ne "<>" and $self->qp->config('rhsbl_zones')) {
+    my %rhsbl_zones = map { (split /\s+/, $_, 2)[0,1] } $self->qp->config('rhsbl_zones');
+    my $host = $sender->host;
+    for my $rhsbl (keys %rhsbl_zones) {
+      $transaction->notes('rhsbl', "Mail from $host rejected because it $rhsbl_zones{$rhsbl}")
+	if check_rhsbl($self, $rhsbl, $host);
+    }
+  }
+}
+
+sub rcpt_handler {
+  my ($self, $transaction, $rcpt) = @_;
+  my $note = $transaction->notes('rhsbl');
+  return (DENY, $note) if $note;
+  return DECLINED;
+}
+
+sub check_rhsbl {
+  my ($self, $rhsbl, $host) = @_;
+  return 0 unless $host;
+  $self->log(2, "checking $host in $rhsbl");
+  return 1 if ((gethostbyname("$host.$rhsbl"))[4]);
+  return 0;
+}
+
+
+

qpsmtpd

@@ -26,36 +26,6 @@ $qpsmtpd->run();
 __END__
 
 
-sub check_rhsbl {
-  my ($rhsbl, $host) = @_;
-  return 0 unless $host;
-  warn "$$ checking $host in $rhsbl\n" if $TRACE > 2;
-  return 1 if ((gethostbyname("$host.$rhsbl"))[4]);
-  return 0;
-}
-
-sub check_dns {
-  my $host = shift;
-
-  # 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;
-  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 {
-    warn "$$ query for $host failed: ", $res->errorstring, "\n"
-      unless $res->errorstring eq "NXDOMAIN";
-  }
-  return 0;
-}
 
 
 1;