16 |
our @EXPORT = qw( |
our @EXPORT = qw( |
17 |
); |
); |
18 |
|
|
19 |
our $VERSION = '0.4'; |
our $VERSION = '0.5'; |
20 |
|
|
21 |
use Class::DBI::Loader; |
use Class::DBI::Loader; |
22 |
use Email::Valid; |
use Email::Valid; |
26 |
use Email::Simple; |
use Email::Simple; |
27 |
use Email::Address; |
use Email::Address; |
28 |
use Mail::DeliveryStatus::BounceParser; |
use Mail::DeliveryStatus::BounceParser; |
29 |
|
use Class::DBI::AbstractSearch; |
30 |
|
|
31 |
|
|
32 |
=head1 NAME |
=head1 NAME |
40 |
|
|
41 |
=head1 DESCRIPTION |
=head1 DESCRIPTION |
42 |
|
|
43 |
Core module for notice sender's functionality. |
Notice sender is mail handler. It is not MTA, since it doesn't know how to |
44 |
|
receive e-mails or send them directly to other hosts. It is not mail list |
45 |
|
manager because it requires programming to add list members and send |
46 |
|
messages. You can think of it as mechanisam for off-loading your e-mail |
47 |
|
sending to remote server using SOAP service. |
48 |
|
|
49 |
|
It's concept is based around B<lists>. Each list can have zero or more |
50 |
|
B<members>. Each list can have zero or more B<messages>. |
51 |
|
|
52 |
|
Here comes a twist: each outgoing message will have unique e-mail generated, |
53 |
|
so Notice Sender will be able to link received replies (or bounces) with |
54 |
|
outgoing messages. |
55 |
|
|
56 |
|
It doesn't do much more than that. It B<can't> create MIME encoded e-mail, |
57 |
|
send attachments, handle 8-bit characters in headers (which have to be |
58 |
|
encoded) or anything else. |
59 |
|
|
60 |
|
It will just queue your e-mail message to particular list (sending it to |
61 |
|
possibly remote Notice Sender SOAP server just once), send it out at |
62 |
|
reasonable rate (so that it doesn't flood your e-mail infrastructure) and |
63 |
|
track replies. |
64 |
|
|
65 |
|
It is best used to send smaller number of messages to more-or-less fixed |
66 |
|
list of recipients while allowing individual responses to be examined. |
67 |
|
Tipical use include replacing php e-mail sending code with SOAP call to |
68 |
|
Notice Sender. It does support additional C<ext_id> field for each member |
69 |
|
which can be used to track some unique identifier from remote system for |
70 |
|
particular user. |
71 |
|
|
72 |
|
It comes with command-line utility C<sender.pl> which can be used to perform |
73 |
|
all available operation from scripts (see C<perldoc sender.pl>). |
74 |
|
This command is also useful for debugging while writing client SOAP |
75 |
|
application. |
76 |
|
|
77 |
=head1 METHODS |
=head1 METHODS |
78 |
|
|
107 |
user => $self->{'user'}, |
user => $self->{'user'}, |
108 |
password => $self->{'passwd'}, |
password => $self->{'passwd'}, |
109 |
namespace => "Nos", |
namespace => "Nos", |
110 |
# additional_classes => qw/Class::DBI::AbstractSearch/, |
additional_classes => qw/Class::DBI::AbstractSearch/, |
111 |
# additional_base_classes => qw/My::Stuff/, |
# additional_base_classes => qw/My::Stuff/, |
112 |
relationships => 1, |
relationships => 1, |
113 |
) || croak "can't init Class::DBI::Loader"; |
) || croak "can't init Class::DBI::Loader"; |
131 |
|
|
132 |
Returns ID of newly created list. |
Returns ID of newly created list. |
133 |
|
|
134 |
Calls internally L<_add_list>, see details there. |
Calls internally C<_add_list>, see details there. |
135 |
|
|
136 |
=cut |
=cut |
137 |
|
|
141 |
my $arg = {@_}; |
my $arg = {@_}; |
142 |
|
|
143 |
confess "need list name" unless ($arg->{'list'}); |
confess "need list name" unless ($arg->{'list'}); |
144 |
confess "need list email" unless ($arg->{'list'}); |
confess "need list email" unless ($arg->{'email'}); |
145 |
|
|
146 |
|
$arg->{'list'} = lc($arg->{'list'}); |
147 |
|
$arg->{'email'} = lc($arg->{'email'}); |
148 |
|
|
149 |
my $l = $self->_get_list($arg->{'list'}) || |
my $l = $self->_get_list($arg->{'list'}) || |
150 |
$self->_add_list( @_ ) || |
$self->_add_list( @_ ) || |
154 |
} |
} |
155 |
|
|
156 |
|
|
157 |
|
=head2 delete_list |
158 |
|
|
159 |
|
Delete list from database. |
160 |
|
|
161 |
|
my $ok = delete_list( |
162 |
|
list => 'My list' |
163 |
|
); |
164 |
|
|
165 |
|
Returns false if list doesn't exist. |
166 |
|
|
167 |
|
=cut |
168 |
|
|
169 |
|
sub delete_list { |
170 |
|
my $self = shift; |
171 |
|
|
172 |
|
my $args = {@_}; |
173 |
|
|
174 |
|
croak "need list to delete" unless ($args->{'list'}); |
175 |
|
|
176 |
|
$args->{'list'} = lc($args->{'list'}); |
177 |
|
|
178 |
|
my $lists = $self->{'loader'}->find_class('lists'); |
179 |
|
|
180 |
|
my $this_list = $lists->search( name => $args->{'list'} )->first || return; |
181 |
|
|
182 |
|
$this_list->delete || croak "can't delete list\n"; |
183 |
|
|
184 |
|
return $lists->dbi_commit || croak "can't commit"; |
185 |
|
} |
186 |
|
|
187 |
|
|
188 |
=head2 add_member_to_list |
=head2 add_member_to_list |
189 |
|
|
190 |
Add new member to list |
Add new member to list |
193 |
list => "My list", |
list => "My list", |
194 |
email => "john.doe@example.com", |
email => "john.doe@example.com", |
195 |
name => "John A. Doe", |
name => "John A. Doe", |
196 |
|
ext_id => 42, |
197 |
); |
); |
198 |
|
|
199 |
C<name> parametar is optional. |
C<name> and C<ext_id> parametars are optional. |
200 |
|
|
201 |
Return member ID if user is added. |
Return member ID if user is added. |
202 |
|
|
207 |
|
|
208 |
my $arg = {@_}; |
my $arg = {@_}; |
209 |
|
|
210 |
my $email = $arg->{'email'} || croak "can't add user without e-mail"; |
my $email = lc($arg->{'email'}) || croak "can't add user without e-mail"; |
211 |
my $name = $arg->{'name'} || ''; |
my $name = $arg->{'name'} || ''; |
212 |
my $list_name = $arg->{'list'} || croak "need list name"; |
my $list_name = lc($arg->{'list'}) || croak "need list name"; |
213 |
|
my $ext_id = $arg->{'ext_id'}; |
214 |
|
|
215 |
my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist"; |
my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist"; |
216 |
|
|
233 |
$this_user->update; |
$this_user->update; |
234 |
} |
} |
235 |
|
|
236 |
|
if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) { |
237 |
|
$this_user->ext_id($ext_id); |
238 |
|
$this_user->update; |
239 |
|
} |
240 |
|
|
241 |
my $user_on_list = $user_list->find_or_create({ |
my $user_on_list = $user_list->find_or_create({ |
242 |
user_id => $this_user->id, |
user_id => $this_user->id, |
243 |
list_id => $list->id, |
list_id => $list->id, |
265 |
email => 'dpavlin@rot13.org |
email => 'dpavlin@rot13.org |
266 |
} |
} |
267 |
|
|
268 |
If list is not found, returns false. |
If list is not found, returns false. If there is C<ext_id> in user data, |
269 |
|
it will also be returned. |
270 |
|
|
271 |
=cut |
=cut |
272 |
|
|
275 |
|
|
276 |
my $args = {@_}; |
my $args = {@_}; |
277 |
|
|
278 |
my $list_name = $args->{'list'} || confess "need list name"; |
my $list_name = lc($args->{'list'}) || confess "need list name"; |
279 |
|
|
280 |
my $lists = $self->{'loader'}->find_class('lists'); |
my $lists = $self->{'loader'}->find_class('lists'); |
281 |
my $user_list = $self->{'loader'}->find_class('user_list'); |
my $user_list = $self->{'loader'}->find_class('user_list'); |
290 |
email => $user_on_list->user_id->email, |
email => $user_on_list->user_id->email, |
291 |
}; |
}; |
292 |
|
|
293 |
|
my $ext_id = $user_on_list->user_id->ext_id; |
294 |
|
$row->{'ext_id'} = $ext_id if (defined($ext_id)); |
295 |
|
|
296 |
push @results, $row; |
push @results, $row; |
297 |
} |
} |
298 |
|
|
315 |
|
|
316 |
Returns false if user doesn't exist. |
Returns false if user doesn't exist. |
317 |
|
|
318 |
|
This function will delete member from all lists (by cascading delete), so it |
319 |
|
shouldn't be used lightly. |
320 |
|
|
321 |
=cut |
=cut |
322 |
|
|
323 |
sub delete_member { |
sub delete_member { |
327 |
|
|
328 |
croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'}); |
croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'}); |
329 |
|
|
330 |
|
$args->{'email'} = lc($args->{'email'}) if ($args->{'email'}); |
331 |
|
|
332 |
my $key = 'name'; |
my $key = 'name'; |
333 |
$key = 'email' if ($args->{'email'}); |
$key = 'email' if ($args->{'email'}); |
334 |
|
|
341 |
return $users->dbi_commit || croak "can't commit"; |
return $users->dbi_commit || croak "can't commit"; |
342 |
} |
} |
343 |
|
|
344 |
|
=head2 delete_member_from_list |
345 |
|
|
346 |
|
Delete member from particular list. |
347 |
|
|
348 |
|
my $ok = delete_member_from_list( |
349 |
|
list => 'My list', |
350 |
|
email => 'dpavlin@rot13.org', |
351 |
|
); |
352 |
|
|
353 |
|
Returns false if user doesn't exist on that particular list. |
354 |
|
|
355 |
|
It will die if list or user doesn't exist. You have been warned (you might |
356 |
|
want to eval this functon to prevent it from croaking). |
357 |
|
|
358 |
|
=cut |
359 |
|
|
360 |
|
sub delete_member_from_list { |
361 |
|
my $self = shift; |
362 |
|
|
363 |
|
my $args = {@_}; |
364 |
|
|
365 |
|
croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'}); |
366 |
|
|
367 |
|
$args->{'list'} = lc($args->{'list'}); |
368 |
|
$args->{'email'} = lc($args->{'email'}); |
369 |
|
|
370 |
|
my $user = $self->{'loader'}->find_class('users'); |
371 |
|
my $list = $self->{'loader'}->find_class('lists'); |
372 |
|
my $user_list = $self->{'loader'}->find_class('user_list'); |
373 |
|
|
374 |
|
my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'}; |
375 |
|
my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'}; |
376 |
|
|
377 |
|
my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return; |
378 |
|
|
379 |
|
$this_user_list->delete || croak "can't delete user from list\n"; |
380 |
|
|
381 |
|
return $user_list->dbi_commit || croak "can't commit"; |
382 |
|
} |
383 |
|
|
384 |
=head2 add_message_to_list |
=head2 add_message_to_list |
385 |
|
|
386 |
Adds message to one list's queue for later sending. |
Adds message to one list's queue for later sending. |
406 |
|
|
407 |
my $args = {@_}; |
my $args = {@_}; |
408 |
|
|
409 |
my $list_name = $args->{'list'} || confess "need list name"; |
my $list_name = lc($args->{'list'}) || confess "need list name"; |
410 |
my $message_text = $args->{'message'} || croak "need message"; |
my $message_text = $args->{'message'} || croak "need message"; |
411 |
|
|
412 |
my $m = Email::Simple->new($message_text) || croak "can't parse message"; |
my $m = Email::Simple->new($message_text) || croak "can't parse message"; |
475 |
|
|
476 |
my $arg = {@_}; |
my $arg = {@_}; |
477 |
|
|
478 |
my $list_name = $arg->{'list'} || ''; |
my $list_name = lc($arg->{'list'}) || ''; |
479 |
my $driver = $arg->{'driver'} || ''; |
my $driver = $arg->{'driver'} || ''; |
480 |
my $sleep = $arg->{'sleep'}; |
my $sleep = $arg->{'sleep'}; |
481 |
$sleep ||= 3 unless defined($sleep); |
$sleep ||= 3 unless defined($sleep); |
486 |
if (lc($driver) eq 'smtp') { |
if (lc($driver) eq 'smtp') { |
487 |
$email_send_driver = 'Email::Send::SMTP'; |
$email_send_driver = 'Email::Send::SMTP'; |
488 |
@email_send_options = ['127.0.0.1']; |
@email_send_options = ['127.0.0.1']; |
489 |
|
} else { |
490 |
|
warn "dumping all messages to STDERR\n"; |
491 |
} |
} |
|
warn "using $driver [$email_send_driver]\n"; |
|
492 |
|
|
493 |
my $lists = $self->{'loader'}->find_class('lists'); |
my $lists = $self->{'loader'}->find_class('lists'); |
494 |
my $queue = $self->{'loader'}->find_class('queue'); |
my $queue = $self->{'loader'}->find_class('queue'); |
520 |
if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) { |
if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) { |
521 |
print "SKIP $to_email message allready sent\n"; |
print "SKIP $to_email message allready sent\n"; |
522 |
} else { |
} else { |
523 |
print "=> $to_email\n"; |
print "=> $to_email "; |
524 |
|
|
525 |
my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id; |
my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id; |
526 |
my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} ); |
my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} ); |
546 |
$m_obj->header_set('X-Nos-Hash', $hash); |
$m_obj->header_set('X-Nos-Hash', $hash); |
547 |
|
|
548 |
# really send e-mail |
# really send e-mail |
549 |
|
my $sent_status; |
550 |
|
|
551 |
if (@email_send_options) { |
if (@email_send_options) { |
552 |
send $email_send_driver => $m_obj->as_string, @email_send_options; |
$sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options; |
553 |
} else { |
} else { |
554 |
send $email_send_driver => $m_obj->as_string; |
$sent_status = send $email_send_driver => $m_obj->as_string; |
555 |
} |
} |
556 |
|
|
557 |
$sent->create({ |
croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status); |
558 |
message_id => $m->message_id, |
my @bad = @{ $sent_status->prop('bad') }; |
559 |
user_id => $u->user_id, |
croak "failed sending to ",join(",",@bad) if (@bad); |
560 |
hash => $hash, |
|
561 |
}); |
if ($sent_status) { |
562 |
$sent->dbi_commit; |
|
563 |
|
$sent->create({ |
564 |
|
message_id => $m->message_id, |
565 |
|
user_id => $u->user_id, |
566 |
|
hash => $hash, |
567 |
|
}); |
568 |
|
$sent->dbi_commit; |
569 |
|
|
570 |
|
print " - $sent_status\n"; |
571 |
|
|
572 |
|
} else { |
573 |
|
warn "ERROR: $sent_status\n"; |
574 |
|
} |
575 |
|
|
576 |
if ($sleep) { |
if ($sleep) { |
577 |
warn "sleeping $sleep seconds\n"; |
warn "sleeping $sleep seconds\n"; |
595 |
message => $message, |
message => $message, |
596 |
); |
); |
597 |
|
|
598 |
|
This method is used by C<sender.pl> when receiving e-mail messages. |
599 |
|
|
600 |
=cut |
=cut |
601 |
|
|
602 |
sub inbox_message { |
sub inbox_message { |
607 |
return unless ($arg->{'message'}); |
return unless ($arg->{'message'}); |
608 |
croak "need list name" unless ($arg->{'list'}); |
croak "need list name" unless ($arg->{'list'}); |
609 |
|
|
610 |
|
$arg->{'list'} = lc($arg->{'list'}); |
611 |
|
|
612 |
my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n"; |
my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n"; |
613 |
|
|
614 |
my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message"; |
my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message"; |
626 |
my $hash; |
my $hash; |
627 |
|
|
628 |
foreach my $a (@addrs) { |
foreach my $a (@addrs) { |
629 |
if ($a->address =~ m/\+([a-f0-9]{$hl})@/) { |
if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) { |
630 |
$hash = $1; |
$hash = $1; |
631 |
last; |
last; |
632 |
} |
} |
650 |
my $users = $self->{'loader'}->find_class('users'); |
my $users = $self->{'loader'}->find_class('users'); |
651 |
my $from = $m->header('From'); |
my $from = $m->header('From'); |
652 |
$from = $1 if ($from =~ m/<(.*)>/); |
$from = $1 if ($from =~ m/<(.*)>/); |
653 |
my $this_user = $users->search( email => $from )->first; |
my $this_user = $users->search( email => lc($from) )->first; |
654 |
$user_id = $this_user->id if ($this_user); |
$user_id = $this_user->id if ($this_user); |
655 |
} |
} |
656 |
|
|
711 |
|
|
712 |
my $arg = {@_}; |
my $arg = {@_}; |
713 |
|
|
714 |
my $name = $arg->{'list'} || confess "can't add list without name"; |
my $name = lc($arg->{'list'}) || confess "can't add list without name"; |
715 |
my $email = $arg->{'email'} || confess "can't add list without e-mail"; |
my $email = lc($arg->{'email'}) || confess "can't add list without e-mail"; |
716 |
my $from_addr = $arg->{'from'}; |
my $from_addr = $arg->{'from'}; |
717 |
|
|
718 |
my $lists = $self->{'loader'}->find_class('lists'); |
my $lists = $self->{'loader'}->find_class('lists'); |
753 |
|
|
754 |
my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class"; |
my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class"; |
755 |
|
|
756 |
return $lists->search({ name => $name })->first; |
return $lists->search({ name => lc($name) })->first; |
757 |
} |
} |
758 |
|
|
759 |
### |
### |
795 |
|
|
796 |
$message_id = NewList( |
$message_id = NewList( |
797 |
list => 'My list', |
list => 'My list', |
798 |
|
from => 'Name of my list', |
799 |
email => 'my-list@example.com' |
email => 'my-list@example.com' |
800 |
); |
); |
801 |
|
|
806 |
|
|
807 |
if ($_[0] !~ m/^HASH/) { |
if ($_[0] !~ m/^HASH/) { |
808 |
return $nos->new_list( |
return $nos->new_list( |
809 |
list => $_[0], email => $_[1], |
list => $_[0], from => $_[1], email => $_[2], |
810 |
); |
); |
811 |
} else { |
} else { |
812 |
return $nos->new_list( %{ shift @_ } ); |
return $nos->new_list( %{ shift @_ } ); |
814 |
} |
} |
815 |
|
|
816 |
|
|
817 |
|
=head2 DeleteList |
818 |
|
|
819 |
|
$ok = DeleteList( |
820 |
|
list => 'My list', |
821 |
|
); |
822 |
|
|
823 |
|
=cut |
824 |
|
|
825 |
|
sub DeleteList { |
826 |
|
my $self = shift; |
827 |
|
|
828 |
|
if ($_[0] !~ m/^HASH/) { |
829 |
|
return $nos->delete_list( |
830 |
|
list => $_[0], |
831 |
|
); |
832 |
|
} else { |
833 |
|
return $nos->delete_list( %{ shift @_ } ); |
834 |
|
} |
835 |
|
} |
836 |
|
|
837 |
=head2 AddMemberToList |
=head2 AddMemberToList |
838 |
|
|
839 |
$member_id = AddMemberToList( |
$member_id = AddMemberToList( |
840 |
list => 'My list', |
list => 'My list', |
841 |
email => 'e-mail@example.com', |
email => 'e-mail@example.com', |
842 |
name => 'Full Name' |
name => 'Full Name', |
843 |
|
ext_id => 42, |
844 |
); |
); |
845 |
|
|
846 |
=cut |
=cut |
850 |
|
|
851 |
if ($_[0] !~ m/^HASH/) { |
if ($_[0] !~ m/^HASH/) { |
852 |
return $nos->add_member_to_list( |
return $nos->add_member_to_list( |
853 |
list => $_[0], email => $_[1], name => $_[2], |
list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4], |
854 |
); |
); |
855 |
} else { |
} else { |
856 |
return $nos->add_member_to_list( %{ shift @_ } ); |
return $nos->add_member_to_list( %{ shift @_ } ); |
866 |
|
|
867 |
Returns array of hashes with user informations, see C<list_members>. |
Returns array of hashes with user informations, see C<list_members>. |
868 |
|
|
869 |
|
Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It |
870 |
|
seems that SOAP::Lite client thinks that it has array with one element which |
871 |
|
is array of hashes with data. |
872 |
|
|
873 |
=cut |
=cut |
874 |
|
|
875 |
sub ListMembers { |
sub ListMembers { |
883 |
$list_name = $_[0]->{'list'}; |
$list_name = $_[0]->{'list'}; |
884 |
} |
} |
885 |
|
|
886 |
return $nos->list_members( list => $list_name ); |
return [ $nos->list_members( list => $list_name ) ]; |
887 |
|
} |
888 |
|
|
889 |
|
|
890 |
|
=head2 DeleteMemberFromList |
891 |
|
|
892 |
|
$member_id = DeleteMemberFromList( |
893 |
|
list => 'My list', |
894 |
|
email => 'e-mail@example.com', |
895 |
|
); |
896 |
|
|
897 |
|
=cut |
898 |
|
|
899 |
|
sub DeleteMemberFromList { |
900 |
|
my $self = shift; |
901 |
|
|
902 |
|
if ($_[0] !~ m/^HASH/) { |
903 |
|
return $nos->delete_member_from_list( |
904 |
|
list => $_[0], email => $_[1], |
905 |
|
); |
906 |
|
} else { |
907 |
|
return $nos->delete_member_from_list( %{ shift @_ } ); |
908 |
|
} |
909 |
} |
} |
910 |
|
|
911 |
|
|
912 |
=head2 AddMessageToList |
=head2 AddMessageToList |
913 |
|
|
914 |
$message_id = AddMessageToList( |
$message_id = AddMessageToList( |