lib/Promulger/Dispatch.pm

   1 package Promulger::Dispatch;
   2 use strict;
   3 use warnings;
   4
   5 use Email::Address;
   6 use Email::Simple;
   7 # XXX allow the user to specify their own Email::Sender::Transport -- apeiron,
   8 # 2010-03-13
   9 use Email::Sender::Simple qw(sendmail);
  10 use Mail::Verp;
  11
  12 use Promulger::Config;
  13
  14 # XXX no bounce parsing yet -- apeiron, 2010-03-13
  15 sub dispatch {
  16   my ($message) = @_;
  17   my $config = Promulger::Config->config;
  18
  19   my $email = Email::Simple->new($message);
  20   my $recipient = $email->header('To');
  21   my $local_user = user_for_address($recipient);
  22   my $sender = $email->header('From');
  23   my $subject = $email->header('Subject');
  24
  25   my $list = Promulger::List->resolve($local_user);
  26   unless($list) {
  27     reject($recipient, $sender);
  28     return;
  29   }
  30
  31   if($local_user =~ /-request$/) {
  32     handle_request($list, $sender, $local_user, $subject, $config);
  33     return;
  34   }
  35
  36   # they don't have a request for us, so they want to post a message
  37   post_message($list, $email, $config);
  38   return;
  39 }
  40
  41 sub handle_request {
  42   my ($list, $sender, $recipient, $subject) = @_;
  43
  44   my $sender_address = bare_address($sender);
  45   if($subject =~ /^\s*subscribe/i) {
  46     $list->subscribe($sender_address)
  47       or already_subscribed($list, $recipient, $sender_address);
  48   } elsif($subject =~ /^\s*unsubscribe/i) {
  49     $list->unsubscribe($sender_address)
  50       or not_subscribed($list, $recipient, $sender_address);
  51   }
  52 }
  53
  54 sub post_message {
  55   my ($list, $email, $config) = @_;
  56
  57   my $sender = $email->header('From');
  58   my $sender_address = bare_address($sender);
  59   my $recipient = $email->header('To');
  60
  61   unless($list->accept_posts_from($sender_address) && $list->active) {
  62     reject($recipient, $sender);
  63     return;
  64   }
  65
  66   # they're allowed to post (subscribed or not), the list is active. let's do
  67   # this thing.
  68
  69   # XXX no MIME or other fancy handling for now -- apeiron, 2010-03-13
  70   my $body = $email->body;
  71   for my $subscriber (keys %{$list->subscribers}) {
  72     #my $verped_from = Mail::Verp->encode($recipient, $subscriber);
  73     # XXX we let the MTA create the message-id for us for now -- apeiron,
  74     # 2010-03-13
  75     my $new_message = Email::Simple->create(
  76       header => [
  77         From => $recipient,
  78         To   => $subscriber,
  79         Subject => $email->header('Subject'),
  80       ],
  81       body => $body,
  82     );
  83     # XXX no queuing or job distribution for now beyond what the MTA provides
  84     # -- apeiron, 2010-03-13
  85     sendmail($new_message);
  86   }
  87 }
  88
  89 # XXX make this actually not suck -- apeiron, 2010-03-13
  90 sub reject {
  91   my ($recipient, $sender) = @_;
  92   my $email = Email::Simple->create(
  93     header => [
  94       From => $recipient,
  95       To   => $sender,
  96       Subject => 'Rejected',
  97     ],
  98     body => <<BODY,
  99 Sorry, your message to $recipient has been denied.
 100 BODY
 101   );
 102   sendmail($email);
 103 }
 104
 105 sub not_subscribed {
 106   my ($list, $recipient, $sender) = @_;
 107   my $email = Email::Simple->create(
 108     # XXX need admin address
 109     header => [
 110       From => $recipient,
 111       To   => $sender,
 112       Subject => 'Not subscribed',
 113     ],
 114     body => <<BODY,
 115 Sorry, you are not subscribed to $list.
 116 BODY
 117   );
 118   sendmail($email);
 119 }
 120
 121 sub already_subscribed {
 122   my ($list, $recipient, $sender) = @_;
 123   my $email = Email::Simple->create(
 124     header => [
 125       From => $recipient,
 126       To   => $sender,
 127       Subject => 'Already subscribed',
 128     ],
 129     body => <<BODY,
 130 Sorry, you are already subscribed to $list.
 131 BODY
 132   );
 133   sendmail($email);
 134 }
 135
 136 sub bare_address {
 137   my ($full_addr) = @_;
 138   my ($addr_obj) = Email::Address->parse($full_addr);
 139   return $addr_obj->address;
 140 }
 141
 142 sub user_for_address {
 143   my ($full_addr) = @_;
 144   my ($addr_obj) = Email::Address->parse($full_addr);
 145   return $addr_obj->user;
 146 }
 147
 148 'http://www.shadowcat.co.uk/blog/matt-s-trout/oh-subdispatch-oh-subdispatch/';