Add rough, untested bounce parsing.

This uses Mail::DeliveryStatus::Bounceparser for want of a better tool.
Most of the logic is in there, so we can treat it as a black box as far
as Promulger is concerned. The rest of the surrounding logic is pretty
simple.

diff --git a/lib/App/Promulger/msgbounce.pm b/lib/App/Promulger/msgbounce.pm
new file mode 100644 (file)
index 0000000..e137746
--- /dev/null
+++ b/lib/App/Promulger/msgbounce.pm
@@ -0,0 +1,22 @@
+package App::Promulger::Command::msgbounce;
+use strictures 1;
+use autodie;
+
+use App::Promulger -command;
+use parent 'App::Promulger::Command';
+use Promulger::Dispatch;
+
+sub abstract {
+  return "handle a potential bounce";
+}
+
+sub run {
+  my ($self, $opt, $args) = @_;
+  my $message = do {
+    local $/;
+    <STDIN>
+  };
+  Promulger::Dispatch->new->handle_bounce($message);
+}
+
+1;

diff --git a/lib/Promulger/Dispatch.pm b/lib/Promulger/Dispatch.pm
index 5e59fc3..d52170d 100644 (file)
--- a/lib/Promulger/Dispatch.pm
+++ b/lib/Promulger/Dispatch.pm
@@ -2,6 +2,7 @@ package Promulger::Dispatch;
 use Moo;
 use autodie ':all';
 use Scalar::Util 'blessed';
+use Try::Tiny;
 
 use Email::Address;
 use Email::MIME;
@@ -10,6 +11,7 @@ use Email::Sender::Simple ();
 #use Mail::Verp;
 
 use Promulger::Config;
+use Promulger::List;
 
 has transport => (
   is => 'rw',
@@ -35,7 +37,6 @@ has transport => (
   },
 );
 
-# XXX no bounce parsing yet -- apeiron, 2010-03-13 
 sub dispatch {
   my ($self, $message) = @_;
   my $config = Promulger::Config->config;
@@ -74,6 +75,37 @@ sub handle_request {
   }
 }
 
+# XXX this needs to be better -- apeiron, 2012-07-18 
+sub handle_bounce {
+  my ($self, $raw_message) = @_;
+  my $message = Email::MIME->new($raw_message);
+  require Mail::DeliveryStatus::BounceParser;
+  my $bounce;
+  my $recipient = $message->header('To');
+  my $recipient_address = Email::Address->parse($recipient);
+  try {
+    my $bounce = Mail::DeliveryStatus::BounceParser->new($message);
+  } catch {
+    my $domain = $recipient_address->host;
+    my $redirect = Email::MIME->create(
+      header_str => [
+        From => $message->header('From'),
+        To   => "postmaster@${domain}",
+        Subject => $message->header('Subject'),
+      ],
+      body_str => $message->body_str,
+    );
+    $self->send_message($redirect);
+  };
+  my @addresses = $bounce->addresses;
+  my $list = Promulger::List->resolve($recipient_address->address);
+  for my $addr (@addresses) {
+    my $a = Email::Address->parse($addr);
+    my $raw_address = $a->address;
+    $list->unsubscribe($raw_address);
+  }
+}
+
 sub post_message {
   my ($self, $list, $email, $config) = @_;
   my $sender = $email->header('From');

diff --git a/lib/Promulger/List.pm b/lib/Promulger/List.pm
index 7040046..d479f3d 100644 (file)
--- a/lib/Promulger/List.pm
+++ b/lib/Promulger/List.pm
@@ -38,6 +38,7 @@ has subscribers => (
 sub resolve {
   my ($self, $proto) = @_;
   $proto =~ s/-request$//;
+  $proto =~ s/^owner-//;
   my $path = find_path_for($proto);
   my $maybe_list;
   try {
@@ -82,12 +83,15 @@ sub setup {
   $tie->flock;
   my @list_aliases = ($name, "${name}-request");
 
+  # XXX add a flag to determine whether to write the aliases file or no
+  # -- apeiron, 2012-07-18
   for my $list_alias (@list_aliases) {
     if(grep { /^${list_alias}:/ } @aliases) {
       croak "${list_alias} already in $config->{aliases}";
     }
     push @aliases, 
-      qq(${list_alias}: "|$Bin msg -c $config->{config_file}"\n);
+      qq(${list_alias}: "|$Bin msg -c $config->{config_file}"\n),
+      qq(${list_alias}-owner: "|$Bin msgbounce -c $config->{config_file}"\n);
   }
 
   $self->store($path->stringify);