lib/Promulger/Dispatch.pm

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