lib/Promulger/Dispatch.pm

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