lib/Promulger/Dispatch.pm

   1 package Promulger::Dispatch;
   2 use Moo;
   3 use autodie ':all';
   4 use Scalar::Util 'blessed';
   5 use Try::Tiny;
   6
   7 use Email::Address;
   8 use Email::MIME;
   9 use Email::Sender::Simple ();
  10 # XXX not yet -- apeiron, 2010-06-25
  11 #use Mail::Verp;
  12
  13 use Promulger::Config;
  14 use Promulger::List;
  15
  16 has transport => (
  17   is => 'rw',
  18   isa => sub {
  19     my $proto = $_[0];
  20     blessed $proto and
  21     $proto->can('does') and
  22     $proto->does('Email::Sender::Transport')
  23       or die "transport must do Email::Sender::Transport role";
  24   },
  25   default => sub {
  26     my $config = Promulger::Config->config;
  27     my $class;
  28     if($class = $config->{mailer}) {
  29       if($class !~ /::/) {
  30         $class = "Email::Sender::Transport::${class}";
  31       }
  32     } else {
  33       $class = 'Email::Sender::Transport::Sendmail';
  34     }
  35     Class::MOP::load_class($class);
  36     $class->new;
  37   },
  38 );
  39
  40 sub dispatch {
  41   my ($self, $message) = @_;
  42   my $config = Promulger::Config->config;
  43
  44   my $email = Email::MIME->new($message);
  45   my $recipient = $email->header('To');
  46   my $local_user = $self->user_for_address($recipient);
  47   my $sender = $email->header('From');
  48   my $subject = $email->header('Subject');
  49
  50   my $list = Promulger::List->resolve($local_user);
  51   unless($list) {
  52     $self->reject($recipient, $sender);
  53     return;
  54   }
  55
  56   if($local_user =~ /-request$/) {
  57     $self->handle_request($list, $sender, $local_user, $subject, $config);
  58     return;
  59   }
  60
  61   # they don't have a request for us, so they want to post a message
  62   $self->post_message($list, $email, $config);
  63   return;
  64 }
  65
  66 sub handle_request {
  67   my ($self, $list, $sender, $recipient, $subject) = @_;
  68   my $sender_address = $self->bare_address($sender);
  69   if($subject =~ /^\s*subscribe/i) {
  70     $list->subscribe($sender_address)
  71       or $self->already_subscribed($list, $recipient, $sender_address);
  72   } elsif($subject =~ /^\s*unsubscribe/i) {
  73     $list->unsubscribe($sender_address)
  74       or $self->not_subscribed($list, $recipient, $sender_address);
  75   }
  76 }
  77
  78 # XXX this needs to be better -- apeiron, 2012-07-18
  79 sub handle_bounce {
  80   my ($self, $raw_message) = @_;
  81   my $message = Email::MIME->new($raw_message);
  82   require Mail::DeliveryStatus::BounceParser;
  83   my $bounce;
  84   my $recipient = $message->header('To');
  85   my $recipient_address = Email::Address->parse($recipient);
  86   try {
  87     my $bounce = Mail::DeliveryStatus::BounceParser->new($message);
  88   } catch {
  89     my $domain = $recipient_address->host;
  90     my $redirect = Email::MIME->create(
  91       header_str => [
  92         From => $message->header('From'),
  93         To   => "postmaster@${domain}",
  94         Subject => $message->header('Subject'),
  95       ],
  96       body_str => $message->body_str,
  97     );
  98     $self->send_message($redirect);
  99   };
 100   my @addresses = $bounce->addresses;
 101   my $list = Promulger::List->resolve($recipient_address->address);
 102   for my $addr (@addresses) {
 103     my $a = Email::Address->parse($addr);
 104     my $raw_address = $a->address;
 105     $list->unsubscribe($raw_address);
 106   }
 107 }
 108
 109 sub post_message {
 110   my ($self, $list, $email, $config) = @_;
 111   my $sender = $email->header('From');
 112   my $sender_address = $self->bare_address($sender);
 113   my $recipient = $email->header('To');
 114
 115   unless($list->accept_posts_from($sender_address) && $list->active) {
 116     $self->reject($recipient, $sender);
 117     return;
 118   }
 119
 120   # XXX no MIME or other fancy handling for now -- apeiron, 2010-03-13
 121   my $body = $email->body_str;
 122   for my $subscriber (keys %{$list->subscribers}) {
 123     # my $verped_from = Mail::Verp->encode($recipient, $subscriber);
 124
 125     # XXX we let the MTA create the message-id for us for now -- apeiron,
 126     # 2010-03-13
 127     my $new_message = Email::MIME->create(
 128       header => [
 129         From       => $sender_address,
 130         To         => $subscriber,
 131         Subject    => $email->header('Subject'),
 132         'Reply-to' => $recipient,
 133       ],
 134       body => $body,
 135     );
 136     # XXX no queuing or job distribution for now beyond what the MTA provides
 137     # -- apeiron, 2010-03-13
 138     $self->send_message($new_message);
 139   }
 140 }
 141
 142 sub send_message {
 143   my ($self, $message) = @_;
 144   Email::Sender::Simple::sendmail(
 145     $message,
 146     {
 147       transport => $self->transport,
 148     }
 149   );
 150 }
 151
 152 # XXX make this actually not suck -- apeiron, 2010-03-13
 153 sub reject {
 154   my ($self, $recipient, $sender) = @_;
 155   my $email = Email::MIME->create(
 156     header => [
 157       From => $recipient,
 158       To   => $sender,
 159       Subject => 'Rejected',
 160     ],
 161     body => <<BODY,
 162 Sorry, your message to $recipient has been denied.
 163 BODY
 164   );
 165   $self->send_message($email);
 166 }
 167
 168 sub not_subscribed {
 169   my ($self, $list, $recipient, $sender) = @_;
 170   my $email = Email::MIME->create(
 171     # XXX need admin address
 172     header => [
 173       From => $recipient,
 174       To   => $sender,
 175       Subject => 'Not subscribed',
 176     ],
 177     body => <<BODY,
 178 Sorry, you are not subscribed to $list.
 179 BODY
 180   );
 181   $self->send_message($email);
 182 }
 183
 184 sub already_subscribed {
 185   my ($self, $list, $recipient, $sender) = @_;
 186   my $email = Email::MIME->create(
 187     header => [
 188       From => $recipient,
 189       To   => $sender,
 190       Subject => 'Already subscribed',
 191     ],
 192     body => <<BODY,
 193 Sorry, you are already subscribed to $list.
 194 BODY
 195   );
 196   $self->send_message($email);
 197 }
 198
 199 sub bare_address {
 200   my ($self, $full_addr) = @_;
 201   my ($addr_obj) = Email::Address->parse($full_addr);
 202   return $addr_obj->address;
 203 }
 204
 205 sub user_for_address {
 206   my ($self, $full_addr) = @_;
 207   my ($addr_obj) = Email::Address->parse($full_addr);
 208   return $addr_obj->user;
 209 }
 210
 211 'http://www.shadowcat.co.uk/blog/matt-s-trout/oh-subdispatch-oh-subdispatch/';