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 # 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::Simple->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     $list->subscribe($sender_address)
  48       or already_subscribed($list, $recipient, $sender_address);
  49   } elsif($subject =~ /^\s*unsubscribe/i) {
  50     $list->unsubscribe($sender_address)
  51       or not_subscribed($list, $recipient, $sender_address);
  52   }
  53 }
  54
  55 sub post_message {
  56   my ($list, $email, $config) = @_;
  57
  58   my $sender = $email->header('From');
  59   my $sender_address = bare_address($sender);
  60   my $recipient = $email->header('To');
  61
  62   unless($list->accept_posts_from($sender_address) && $list->active) {
  63     reject($recipient, $sender);
  64     return;
  65   }
  66
  67   # they're allowed to post (subscribed or not), the list is active. let's do
  68   # this thing.
  69
  70   # XXX no MIME or other fancy handling for now -- apeiron, 2010-03-13
  71   my $body = $email->body;
  72   for my $subscriber (keys %{$list->subscribers}) {
  73     #my $verped_from = Mail::Verp->encode($recipient, $subscriber);
  74     # XXX we let the MTA create the message-id for us for now -- apeiron,
  75     # 2010-03-13
  76     my $new_message = Email::Simple->create(
  77       header => [
  78         From => $recipient,
  79         To   => $subscriber,
  80         Subject => $email->header('Subject'),
  81       ],
  82       body => $body,
  83     );
  84     # XXX no queuing or job distribution for now beyond what the MTA provides
  85     # -- apeiron, 2010-03-13
  86     sendmail($new_message);
  87   }
  88 }
  89
  90 # XXX make this actually not suck -- apeiron, 2010-03-13
  91 sub reject {
  92   my ($recipient, $sender) = @_;
  93   my $email = Email::Simple->create(
  94     header => [
  95       From => $recipient,
  96       To   => $sender,
  97       Subject => 'Rejected',
  98     ],
  99     body => <<BODY,
 100 Sorry, your message to $recipient has been denied.
 101 BODY
 102   );
 103   sendmail($email);
 104 }
 105
 106 sub not_subscribed {
 107   my ($list, $recipient, $sender) = @_;
 108   my $email = Email::Simple->create(
 109     # XXX need admin address
 110     header => [
 111       From => $recipient,
 112       To   => $sender,
 113       Subject => 'Not subscribed',
 114     ],
 115     body => <<BODY,
 116 Sorry, you are not subscribed to $list.
 117 BODY
 118   );
 119   sendmail($email);
 120 }
 121
 122 sub already_subscribed {
 123   my ($list, $recipient, $sender) = @_;
 124   my $email = Email::Simple->create(
 125     header => [
 126       From => $recipient,
 127       To   => $sender,
 128       Subject => 'Already subscribed',
 129     ],
 130     body => <<BODY,
 131 Sorry, you are already subscribed to $list.
 132 BODY
 133   );
 134   sendmail($email);
 135 }
 136
 137 sub bare_address {
 138   my ($full_addr) = @_;
 139   my ($addr_obj) = Email::Address->parse($full_addr);
 140   return $addr_obj->address;
 141 }
 142
 143 sub user_for_address {
 144   my ($full_addr) = @_;
 145   my ($addr_obj) = Email::Address->parse($full_addr);
 146   return $addr_obj->user;
 147 }
 148
 149 'http://www.shadowcat.co.uk/blog/matt-s-trout/oh-subdispatch-oh-subdispatch/';