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