lib/Promulger/Dispatch.pm

   1 package Promulger::Dispatch;
   2 use Moo;
   3 use Method::Signatures::Simple;
   4 use autodie ':all';
   5
   6 use Email::Address;
   7 use Email::MIME;
   8 use Email::Sender::Simple ();
   9 # XXX not yet -- apeiron, 2010-06-25
  10 #use Mail::Verp;
  11
  12 use Promulger::Config;
  13
  14 has transport => (
  15   is => 'rw',
  16   isa => sub {
  17     my $proto = $_[0];
  18     blessed $proto and
  19     $proto->can('does') and
  20     $proto->does('Email::Sender::Transport')
  21       or die "transport must do Email::Sender::Transport role";
  22   },
  23   default => sub {
  24     Email::Sender::Transport::Sendmail->new
  25   },
  26 );
  27
  28 # XXX no bounce parsing yet -- apeiron, 2010-03-13
  29 method dispatch ($message) {
  30   my $config = Promulger::Config->config;
  31
  32   my $email = Email::MIME->new($message);
  33   my $recipient = $email->header('To');
  34   my $local_user = $self->user_for_address($recipient);
  35   my $sender = $email->header('From');
  36   my $subject = $email->header('Subject');
  37
  38   my $list = Promulger::List->resolve($local_user);
  39   unless($list) {
  40     $self->reject($recipient, $sender);
  41     return;
  42   }
  43
  44   if($local_user =~ /-request$/) {
  45     $self->handle_request($list, $sender, $local_user, $subject, $config);
  46     return;
  47   }
  48
  49   # they don't have a request for us, so they want to post a message
  50   $self->post_message($list, $email, $config);
  51   return;
  52 }
  53
  54 method handle_request ($list, $sender, $recipient, $subject) {
  55   my $sender_address = $self->bare_address($sender);
  56   if($subject =~ /^\s*subscribe/i) {
  57     $list->subscribe($sender_address)
  58       or $self->already_subscribed($list, $recipient, $sender_address);
  59   } elsif($subject =~ /^\s*unsubscribe/i) {
  60     $list->unsubscribe($sender_address)
  61       or $self->not_subscribed($list, $recipient, $sender_address);
  62   }
  63 }
  64
  65 method post_message ($list, $email, $config) {
  66   my $sender = $email->header('From');
  67   my $sender_address = $self->bare_address($sender);
  68   my $recipient = $email->header('To');
  69
  70   unless($list->accept_posts_from($sender_address) && $list->active) {
  71     $self->reject($recipient, $sender);
  72     return;
  73   }
  74
  75   # XXX no MIME or other fancy handling for now -- apeiron, 2010-03-13
  76   my $body = $email->body_str;
  77   for my $subscriber (keys %{$list->subscribers}) {
  78     # my $verped_from = Mail::Verp->encode($recipient, $subscriber);
  79
  80     # XXX we let the MTA create the message-id for us for now -- apeiron,
  81     # 2010-03-13
  82     my $new_message = Email::MIME->create(
  83       header => [
  84         From       => $sender_address,
  85         To         => $subscriber,
  86         Subject    => $email->header('Subject'),
  87         'Reply-to' => $recipient,
  88       ],
  89       body => $body,
  90     );
  91     # XXX no queuing or job distribution for now beyond what the MTA provides
  92     # -- apeiron, 2010-03-13
  93     $self->send_message($new_message);
  94   }
  95 }
  96
  97 method send_message ($message) {
  98   my $config = Promulger::Config->config;
  99   my ($class, $transport);
 100   if($class = $config->{mailer}) {
 101     if($class !~ /::/) {
 102       $class = "Email::Sender::Transport::${class}";
 103     }
 104   } else {
 105     $class = 'Email::Sender::Transport::Sendmail';
 106   }
 107   Class::MOP::load_class($class);
 108   $transport = $class->new;
 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/';