Line # Revision Author
1 20 dpavlin package Nos;
2
3 use 5.008;
4 use strict;
5 use warnings;
6
7 require Exporter;
8
9 our @ISA = qw(Exporter);
10
11 our %EXPORT_TAGS = ( 'all' => [ qw(
12 ) ] );
13
14 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
15
16 our @EXPORT = qw(
17 );
18
19 93 dpavlin our $VERSION = '0.9';
20 20 dpavlin
21 use Class::DBI::Loader;
22 use Email::Valid;
23 use Email::Send;
24 use Carp;
25 29 dpavlin use Email::Auth::AddressHash;
26 use Email::Simple;
27 36 dpavlin use Email::Address;
28 37 dpavlin use Mail::DeliveryStatus::BounceParser;
29 59 dpavlin use Class::DBI::AbstractSearch;
30 77 dpavlin use SQL::Abstract;
31 66 dpavlin use Mail::Alias;
32 use Cwd qw(abs_path);
33 20 dpavlin
34 47 dpavlin
35 20 dpavlin =head1 NAME
36
37 Nos - Notice Sender core module
38
39 =head1 SYNOPSIS
40
41 use Nos;
42 my $nos = new Nos();
43
44 =head1 DESCRIPTION
45
46 60 dpavlin Notice sender is mail handler. It is not MTA, since it doesn't know how to
47 receive e-mails or send them directly to other hosts. It is not mail list
48 manager because it requires programming to add list members and send
49 messages. You can think of it as mechanisam for off-loading your e-mail
50 sending to remote server using SOAP service.
51 20 dpavlin
52 60 dpavlin It's concept is based around B<lists>. Each list can have zero or more
53 B<members>. Each list can have zero or more B<messages>.
54
55 Here comes a twist: each outgoing message will have unique e-mail generated,
56 so Notice Sender will be able to link received replies (or bounces) with
57 outgoing messages.
58
59 It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
60 send attachments, handle 8-bit characters in headers (which have to be
61 encoded) or anything else.
62
63 It will just queue your e-mail message to particular list (sending it to
64 possibly remote Notice Sender SOAP server just once), send it out at
65 reasonable rate (so that it doesn't flood your e-mail infrastructure) and
66 74 dpavlin keep track replies.
67 60 dpavlin
68 74 dpavlin It is best used to send small number of messages to more-or-less fixed
69 60 dpavlin list of recipients while allowing individual responses to be examined.
70 Tipical use include replacing php e-mail sending code with SOAP call to
71 Notice Sender. It does support additional C<ext_id> field for each member
72 which can be used to track some unique identifier from remote system for
73 particular user.
74
75 It comes with command-line utility C<sender.pl> which can be used to perform
76 74 dpavlin all available operation from scripts (see C<sender.pl --man>).
77 60 dpavlin This command is also useful for debugging while writing client SOAP
78 application.
79
80 20 dpavlin =head1 METHODS
81
82 =head2 new
83
84 Create new instance specifing database, user, password and options.
85
86 my $nos = new Nos(
87 dsn => 'dbi:Pg:dbname=notices',
88 user => 'dpavlin',
89 passwd => '',
90 debug => 1,
91 verbose => 1,
92 36 dpavlin hash_len => 8,
93 89 dpavlin full_hostname_in_aliases => 0,
94 20 dpavlin );
95
96 38 dpavlin Parametar C<hash_len> defines length of hash which will be added to each
97 outgoing e-mail message to ensure that replies can be linked with sent e-mails.
98 36 dpavlin
99 89 dpavlin C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
100 postalias) to include full hostname in aliases file.
101
102
103 20 dpavlin =cut
104
105 sub new {
106 89 dpavlin my $class = shift;
107 my $self = {@_};
108 20 dpavlin bless($self, $class);
109
110 22 dpavlin croak "need at least dsn" unless ($self->{'dsn'});
111
112 20 dpavlin $self->{'loader'} = Class::DBI::Loader->new(
113 debug => $self->{'debug'},
114 dsn => $self->{'dsn'},
115 user => $self->{'user'},
116 password => $self->{'passwd'},
117 namespace => "Nos",
118 59 dpavlin additional_classes => qw/Class::DBI::AbstractSearch/,
119 20 dpavlin # additional_base_classes => qw/My::Stuff/,
120 relationships => 1,
121 22 dpavlin ) || croak "can't init Class::DBI::Loader";
122 20 dpavlin
123 36 dpavlin $self->{'hash_len'} ||= 8;
124
125 20 dpavlin $self ? return $self : return undef;
126 }
127
128 30 dpavlin
129 72 dpavlin =head2 create_list
130 33 dpavlin
131 67 dpavlin Create new list. Required arguments are name of C<list>, C<email> address
132 and path to C<aliases> file.
133 33 dpavlin
134 72 dpavlin $nos->create_list(
135 38 dpavlin list => 'My list',
136 47 dpavlin from => 'Outgoing from comment',
137 33 dpavlin email => 'my-list@example.com',
138 67 dpavlin aliases => '/etc/mail/mylist',
139 archive => '/path/to/mbox/archive',
140 33 dpavlin );
141
142 Returns ID of newly created list.
143
144 60 dpavlin Calls internally C<_add_list>, see details there.
145 38 dpavlin
146 33 dpavlin =cut
147
148 72 dpavlin sub create_list {
149 33 dpavlin my $self = shift;
150
151 my $arg = {@_};
152
153 confess "need list name" unless ($arg->{'list'});
154 52 dpavlin confess "need list email" unless ($arg->{'email'});
155 33 dpavlin
156 52 dpavlin $arg->{'list'} = lc($arg->{'list'});
157 $arg->{'email'} = lc($arg->{'email'});
158
159 33 dpavlin my $l = $self->_get_list($arg->{'list'}) ||
160 $self->_add_list( @_ ) ||
161 return undef;
162
163 return $l->id;
164 }
165
166
167 72 dpavlin =head2 drop_list
168 63 dpavlin
169 Delete list from database.
170
171 72 dpavlin my $ok = drop_list(
172 63 dpavlin list => 'My list'
173 70 dpavlin aliases => '/etc/mail/mylist',
174 63 dpavlin );
175
176 Returns false if list doesn't exist.
177
178 =cut
179
180 72 dpavlin sub drop_list {
181 63 dpavlin my $self = shift;
182
183 my $args = {@_};
184
185 croak "need list to delete" unless ($args->{'list'});
186
187 $args->{'list'} = lc($args->{'list'});
188
189 70 dpavlin my $aliases = $args->{'aliases'} || croak "need path to aliases file";
190
191 63 dpavlin my $lists = $self->{'loader'}->find_class('lists');
192
193 my $this_list = $lists->search( name => $args->{'list'} )->first || return;
194
195 70 dpavlin $self->_remove_alias( email => $this_list->email, aliases => $aliases);
196
197 63 dpavlin $this_list->delete || croak "can't delete list\n";
198
199 return $lists->dbi_commit || croak "can't commit";
200 }
201
202
203 23 dpavlin =head2 add_member_to_list
204
205 Add new member to list
206
207 $nos->add_member_to_list(
208 list => "My list",
209 email => "john.doe@example.com",
210 name => "John A. Doe",
211 56 dpavlin ext_id => 42,
212 23 dpavlin );
213
214 56 dpavlin C<name> and C<ext_id> parametars are optional.
215 23 dpavlin
216 27 dpavlin Return member ID if user is added.
217 23 dpavlin
218 =cut
219
220 sub add_member_to_list {
221 my $self = shift;
222
223 my $arg = {@_};
224
225 52 dpavlin my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
226 23 dpavlin my $name = $arg->{'name'} || '';
227 52 dpavlin my $list_name = lc($arg->{'list'}) || croak "need list name";
228 56 dpavlin my $ext_id = $arg->{'ext_id'};
229 23 dpavlin
230 30 dpavlin my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
231
232 23 dpavlin if (! Email::Valid->address($email)) {
233 33 dpavlin carp "SKIPPING $name <$email>\n";
234 23 dpavlin return 0;
235 }
236
237 29 dpavlin carp "# $name <$email>\n" if ($self->{'verbose'});
238 23 dpavlin
239 my $users = $self->{'loader'}->find_class('users');
240 my $user_list = $self->{'loader'}->find_class('user_list');
241
242 my $this_user = $users->find_or_create({
243 email => $email,
244 }) || croak "can't find or create member\n";
245
246 45 dpavlin if ($name && $this_user->name ne $name) {
247 $this_user->name($name || '');
248 33 dpavlin $this_user->update;
249 }
250
251 56 dpavlin if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
252 $this_user->ext_id($ext_id);
253 $this_user->update;
254 }
255
256 23 dpavlin my $user_on_list = $user_list->find_or_create({
257 user_id => $this_user->id,
258 list_id => $list->id,
259 }) || croak "can't add user to list";
260
261 $list->dbi_commit;
262 $this_user->dbi_commit;
263 $user_on_list->dbi_commit;
264
265 27 dpavlin return $this_user->id;
266 23 dpavlin }
267
268 43 dpavlin =head2 list_members
269
270 45 dpavlin List all members of some list.
271
272 43 dpavlin my @members = list_members(
273 list => 'My list',
274 );
275
276 74 dpavlin Returns array of hashes with user information like this:
277 43 dpavlin
278 $member = {
279 45 dpavlin name => 'Dobrica Pavlinusic',
280 43 dpavlin email => 'dpavlin@rot13.org
281 }
282
283 56 dpavlin If list is not found, returns false. If there is C<ext_id> in user data,
284 60 dpavlin it will also be returned.
285 45 dpavlin
286 43 dpavlin =cut
287
288 sub list_members {
289 my $self = shift;
290
291 my $args = {@_};
292
293 52 dpavlin my $list_name = lc($args->{'list'}) || confess "need list name";
294 43 dpavlin
295 my $lists = $self->{'loader'}->find_class('lists');
296 my $user_list = $self->{'loader'}->find_class('user_list');
297
298 45 dpavlin my $this_list = $lists->search( name => $list_name )->first || return;
299 43 dpavlin
300 my @results;
301
302 foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
303 my $row = {
304 45 dpavlin name => $user_on_list->user_id->name,
305 43 dpavlin email => $user_on_list->user_id->email,
306 };
307
308 56 dpavlin my $ext_id = $user_on_list->user_id->ext_id;
309 $row->{'ext_id'} = $ext_id if (defined($ext_id));
310
311 43 dpavlin push @results, $row;
312 }
313
314 return @results;
315
316 }
317
318
319 45 dpavlin =head2 delete_member
320
321 Delete member from database.
322
323 my $ok = delete_member(
324 name => 'Dobrica Pavlinusic'
325 );
326
327 my $ok = delete_member(
328 email => 'dpavlin@rot13.org'
329 );
330
331 Returns false if user doesn't exist.
332
333 60 dpavlin This function will delete member from all lists (by cascading delete), so it
334 shouldn't be used lightly.
335
336 45 dpavlin =cut
337
338 sub delete_member {
339 my $self = shift;
340
341 my $args = {@_};
342
343 croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
344
345 52 dpavlin $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
346
347 45 dpavlin my $key = 'name';
348 $key = 'email' if ($args->{'email'});
349
350 my $users = $self->{'loader'}->find_class('users');
351
352 my $this_user = $users->search( $key => $args->{$key} )->first || return;
353
354 $this_user->delete || croak "can't delete user\n";
355
356 return $users->dbi_commit || croak "can't commit";
357 }
358
359 59 dpavlin =head2 delete_member_from_list
360
361 Delete member from particular list.
362
363 my $ok = delete_member_from_list(
364 list => 'My list',
365 email => 'dpavlin@rot13.org',
366 );
367
368 Returns false if user doesn't exist on that particular list.
369
370 It will die if list or user doesn't exist. You have been warned (you might
371 want to eval this functon to prevent it from croaking).
372
373 =cut
374
375 sub delete_member_from_list {
376 my $self = shift;
377
378 my $args = {@_};
379
380 croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
381
382 $args->{'list'} = lc($args->{'list'});
383 $args->{'email'} = lc($args->{'email'});
384
385 my $user = $self->{'loader'}->find_class('users');
386 my $list = $self->{'loader'}->find_class('lists');
387 my $user_list = $self->{'loader'}->find_class('user_list');
388
389 my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
390 my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
391
392 62 dpavlin my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
393 59 dpavlin
394 $this_user_list->delete || croak "can't delete user from list\n";
395
396 return $user_list->dbi_commit || croak "can't commit";
397 }
398
399 29 dpavlin =head2 add_message_to_list
400 24 dpavlin
401 Adds message to one list's queue for later sending.
402
403 29 dpavlin $nos->add_message_to_list(
404 24 dpavlin list => 'My list',
405 36 dpavlin message => 'Subject: welcome to list
406 38 dpavlin
407 24 dpavlin This is example message
408 ',
409 );
410
411 On success returns ID of newly created (or existing) message.
412
413 36 dpavlin Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
414 will be automatically generated, but if you want to use own headers, just
415 include them in messages.
416
417 24 dpavlin =cut
418
419 29 dpavlin sub add_message_to_list {
420 24 dpavlin my $self = shift;
421
422 my $args = {@_};
423
424 52 dpavlin my $list_name = lc($args->{'list'}) || confess "need list name";
425 24 dpavlin my $message_text = $args->{'message'} || croak "need message";
426
427 29 dpavlin my $m = Email::Simple->new($message_text) || croak "can't parse message";
428
429 87 dpavlin warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
430 29 dpavlin
431 24 dpavlin my $lists = $self->{'loader'}->find_class('lists');
432
433 my $this_list = $lists->search(
434 name => $list_name,
435 )->first || croak "can't find list $list_name";
436
437 my $messages = $self->{'loader'}->find_class('messages');
438
439 my $this_message = $messages->find_or_create({
440 message => $message_text
441 }) || croak "can't insert message";
442
443 $this_message->dbi_commit() || croak "can't add message";
444
445 my $queue = $self->{'loader'}->find_class('queue');
446
447 $queue->find_or_create({
448 message_id => $this_message->id,
449 list_id => $this_list->id,
450 }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
451
452 $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
453
454 return $this_message->id;
455 }
456
457
458 22 dpavlin =head2 send_queued_messages
459 20 dpavlin
460 22 dpavlin Send queued messages or just ones for selected list
461 20 dpavlin
462 49 dpavlin $nos->send_queued_messages(
463 list => 'My list',
464 driver => 'smtp',
465 sleep => 3,
466 93 dpavlin verbose => 1,
467 49 dpavlin );
468 20 dpavlin
469 47 dpavlin Second option is driver which will be used for e-mail delivery. If not
470 specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
471
472 Other valid drivers are:
473
474 =over 10
475
476 =item smtp
477
478 Send e-mail using SMTP server at 127.0.0.1
479
480 93 dpavlin =item verbose
481
482 Display diagnostic output to C<STDOUT> and C<STDERR>.
483
484 47 dpavlin =back
485
486 75 dpavlin Any other driver name will try to use C<Email::Send::that_driver> module.
487
488 49 dpavlin Default sleep wait between two messages is 3 seconds.
489
490 75 dpavlin This method will return number of succesfully sent messages.
491
492 21 dpavlin =cut
493 20 dpavlin
494 22 dpavlin sub send_queued_messages {
495 21 dpavlin my $self = shift;
496 20 dpavlin
497 49 dpavlin my $arg = {@_};
498 20 dpavlin
499 52 dpavlin my $list_name = lc($arg->{'list'}) || '';
500 49 dpavlin my $driver = $arg->{'driver'} || '';
501 my $sleep = $arg->{'sleep'};
502 93 dpavlin my $verbose = $arg->{verbose};
503 49 dpavlin $sleep ||= 3 unless defined($sleep);
504 47 dpavlin
505 75 dpavlin # number of messages sent o.k.
506 my $ok = 0;
507
508 49 dpavlin my $email_send_driver = 'Email::Send::IO';
509 my @email_send_options;
510
511 47 dpavlin if (lc($driver) eq 'smtp') {
512 $email_send_driver = 'Email::Send::SMTP';
513 @email_send_options = ['127.0.0.1'];
514 75 dpavlin } elsif ($driver && $driver ne '') {
515 $email_send_driver = 'Email::Send::' . $driver;
516 52 dpavlin } else {
517 93 dpavlin warn "dumping all messages to STDERR\n" if ($verbose);
518 47 dpavlin }
519
520 22 dpavlin my $lists = $self->{'loader'}->find_class('lists');
521 my $queue = $self->{'loader'}->find_class('queue');
522 my $user_list = $self->{'loader'}->find_class('user_list');
523 my $sent = $self->{'loader'}->find_class('sent');
524 20 dpavlin
525 22 dpavlin my $my_q;
526 if ($list_name ne '') {
527 my $l_id = $lists->search_like( name => $list_name )->first ||
528 croak "can't find list $list_name";
529 $my_q = $queue->search_like( list_id => $l_id ) ||
530 croak "can't find list $list_name";
531 } else {
532 $my_q = $queue->retrieve_all;
533 }
534 20 dpavlin
535 22 dpavlin while (my $m = $my_q->next) {
536 next if ($m->all_sent);
537 20 dpavlin
538 93 dpavlin print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n" if ($verbose);
539 22 dpavlin my $msg = $m->message_id->message;
540 20 dpavlin
541 22 dpavlin foreach my $u ($user_list->search(list_id => $m->list_id)) {
542 20 dpavlin
543 29 dpavlin my $to_email = $u->user_id->email;
544
545 32 dpavlin my ($from,$domain) = split(/@/, $u->list_id->email, 2);
546
547 22 dpavlin if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
548 93 dpavlin print "SKIP $to_email message allready sent\n" if ($verbose);
549 22 dpavlin } else {
550 93 dpavlin print "=> $to_email " if ($verbose);
551 20 dpavlin
552 32 dpavlin my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
553 36 dpavlin my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
554 32 dpavlin
555 29 dpavlin my $hash = $auth->generate_hash( $to_email );
556 20 dpavlin
557 47 dpavlin my $from_addr;
558 49 dpavlin my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
559 48 dpavlin
560 47 dpavlin $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
561 $from_addr .= '<' . $from_email_only . '>';
562 my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
563 29 dpavlin
564 32 dpavlin my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
565 29 dpavlin
566 49 dpavlin $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
567 86 dpavlin #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
568 49 dpavlin $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
569 47 dpavlin $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
570 32 dpavlin $m_obj->header_set('To', $to) || croak "can't set To: header";
571 29 dpavlin
572 38 dpavlin $m_obj->header_set('X-Nos-Version', $VERSION);
573 $m_obj->header_set('X-Nos-Hash', $hash);
574
575 47 dpavlin # really send e-mail
576 65 dpavlin my $sent_status;
577
578 47 dpavlin if (@email_send_options) {
579 65 dpavlin $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
580 47 dpavlin } else {
581 65 dpavlin $sent_status = send $email_send_driver => $m_obj->as_string;
582 47 dpavlin }
583 22 dpavlin
584 65 dpavlin croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
585 75 dpavlin my @bad;
586 @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
587 65 dpavlin croak "failed sending to ",join(",",@bad) if (@bad);
588 49 dpavlin
589 65 dpavlin if ($sent_status) {
590
591 $sent->create({
592 message_id => $m->message_id,
593 user_id => $u->user_id,
594 hash => $hash,
595 });
596 $sent->dbi_commit;
597
598 93 dpavlin print " - $sent_status\n" if ($verbose);
599 65 dpavlin
600 75 dpavlin $ok++;
601 65 dpavlin } else {
602 93 dpavlin warn "ERROR: $sent_status\n" if ($verbose);
603 65 dpavlin }
604
605 49 dpavlin if ($sleep) {
606 93 dpavlin warn "sleeping $sleep seconds\n" if ($verbose);
607 49 dpavlin sleep($sleep);
608 }
609 22 dpavlin }
610 }
611 $m->all_sent(1);
612 $m->update;
613 $m->dbi_commit;
614 }
615
616 75 dpavlin return $ok;
617
618 20 dpavlin }
619
620 29 dpavlin =head2 inbox_message
621
622 Receive single message for list's inbox.
623
624 36 dpavlin my $ok = $nos->inbox_message(
625 list => 'My list',
626 message => $message,
627 );
628 29 dpavlin
629 60 dpavlin This method is used by C<sender.pl> when receiving e-mail messages.
630
631 29 dpavlin =cut
632
633 sub inbox_message {
634 my $self = shift;
635
636 36 dpavlin my $arg = {@_};
637 29 dpavlin
638 36 dpavlin return unless ($arg->{'message'});
639 croak "need list name" unless ($arg->{'list'});
640 29 dpavlin
641 52 dpavlin $arg->{'list'} = lc($arg->{'list'});
642
643 37 dpavlin my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
644
645 36 dpavlin my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
646
647 my $to = $m->header('To') || die "can't find To: address in incomming message\n";
648
649 48 dpavlin my $return_path = $m->header('Return-Path') || '';
650
651 36 dpavlin my @addrs = Email::Address->parse( $to );
652
653 die "can't parse To: $to address\n" unless (@addrs);
654
655 my $hl = $self->{'hash_len'} || confess "no hash_len?";
656
657 my $hash;
658
659 foreach my $a (@addrs) {
660 52 dpavlin if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
661 36 dpavlin $hash = $1;
662 last;
663 }
664 }
665
666 50 dpavlin #warn "can't find hash in e-mail $to\n" unless ($hash);
667 36 dpavlin
668 my $sent = $self->{'loader'}->find_class('sent');
669
670 # will use null if no matching message_id is found
671 50 dpavlin my $sent_msg;
672 $sent_msg = $sent->search( hash => $hash )->first if ($hash);
673 36 dpavlin
674 37 dpavlin my ($message_id, $user_id) = (undef, undef); # init with NULL
675 36 dpavlin
676 37 dpavlin if ($sent_msg) {
677 $message_id = $sent_msg->message_id || carp "no message_id";
678 $user_id = $sent_msg->user_id || carp "no user_id";
679 47 dpavlin } else {
680 50 dpavlin #warn "can't find sender with hash $hash\n";
681 my $users = $self->{'loader'}->find_class('users');
682 my $from = $m->header('From');
683 $from = $1 if ($from =~ m/<(.*)>/);
684 52 dpavlin my $this_user = $users->search( email => lc($from) )->first;
685 50 dpavlin $user_id = $this_user->id if ($this_user);
686 37 dpavlin }
687
688
689 my $is_bounce = 0;
690
691 49 dpavlin if ($return_path eq '<>' || $return_path eq '') {
692 47 dpavlin no warnings;
693 my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
694 $arg->{'message'}, { report_non_bounces=>1 },
695 ) };
696 50 dpavlin #warn "can't check if this message is bounce!" if ($@);
697 47 dpavlin
698 $is_bounce++ if ($bounce && $bounce->is_bounce);
699 }
700 37 dpavlin
701 my $received = $self->{'loader'}->find_class('received');
702
703 my $this_received = $received->find_or_create({
704 user_id => $user_id,
705 list_id => $this_list->id,
706 message_id => $message_id,
707 message => $arg->{'message'},
708 bounced => $is_bounce,
709 }) || croak "can't insert received message";
710
711 $this_received->dbi_commit;
712
713 49 dpavlin # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
714 29 dpavlin }
715
716 75 dpavlin =head2 received_messages
717 29 dpavlin
718 75 dpavlin Returns all received messages for given list or user.
719
720 80 dpavlin my @received = $nos->received_messages(
721 75 dpavlin list => 'My list',
722 email => "john.doe@example.com",
723 80 dpavlin from_date => '2005-01-01 10:15:00',
724 to_date => '2005-01-01 12:00:00',
725 message => 0,
726 75 dpavlin );
727
728 80 dpavlin If don't specify C<list> or C<email> it will return all received messages.
729 Results will be sorted by received date, oldest first.
730
731 Other optional parametars include:
732
733 =over 10
734
735 =item from_date
736
737 Date (in ISO format) for lower limit of dates received
738
739 =item to_date
740
741 Return just messages older than this date
742
743 =item message
744
745 Include whole received message in result. This will probably make result
746 array very large. Use with care.
747
748 =back
749
750 81 dpavlin Date ranges are inclusive, so results will include messages sent on
751 particular date specified with C<date_from> or C<date_to>.
752
753 76 dpavlin Each element in returned array will have following structure:
754 75 dpavlin
755 80 dpavlin my $row = {
756 76 dpavlin id => 42, # unique ID of received message
757 78 dpavlin list => 'My list', # useful if filtering by email
758 ext_id => 9999, # ext_id from message sender
759 email => 'jdoe@example.com', # e-mail of message sender
760 bounced => 0, # true if message is bounce
761 date => '2005-08-24 18:57:24', # date of receival in ISO format
762 76 dpavlin }
763
764 80 dpavlin If you specified C<message> option, this hash will also have C<message> key
765 which will contain whole received message.
766 76 dpavlin
767 75 dpavlin =cut
768
769 sub received_messages {
770 my $self = shift;
771
772 77 dpavlin my $arg = {@_} if (@_);
773 75 dpavlin
774 77 dpavlin # croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
775 75 dpavlin
776 77 dpavlin my $sql = qq{
777 select
778 received.id as id,
779 lists.name as list,
780 users.ext_id as ext_id,
781 users.email as email,
782 80 dpavlin };
783 $sql .= qq{ message,} if ($arg->{'message'});
784 $sql .= qq{
785 77 dpavlin bounced,received.date as date
786 from received
787 join lists on lists.id = list_id
788 join users on users.id = user_id
789 };
790 75 dpavlin
791 81 dpavlin my $order = qq{ order by date asc };
792 80 dpavlin
793 77 dpavlin my $where;
794 75 dpavlin
795 77 dpavlin $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
796 $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
797 80 dpavlin $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
798 $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
799 77 dpavlin
800 # hum, yammy one-liner
801 my($stmt, @bind) = SQL::Abstract->new->where($where);
802
803 my $dbh = $self->{'loader'}->find_class('received')->db_Main;
804
805 80 dpavlin my $sth = $dbh->prepare($sql . $stmt . $order);
806 77 dpavlin $sth->execute(@bind);
807 76 dpavlin return $sth->fetchall_hash;
808 75 dpavlin }
809
810
811 30 dpavlin =head1 INTERNAL METHODS
812
813 Beware of dragons! You shouldn't need to call those methods directly.
814
815 66 dpavlin
816 =head2 _add_aliases
817
818 71 dpavlin Add or update alias in C</etc/aliases> (or equivalent) file for selected list
819 66 dpavlin
820 my $ok = $nos->add_aliases(
821 list => 'My list',
822 email => 'my-list@example.com',
823 aliases => '/etc/mail/mylist',
824 archive => '/path/to/mbox/archive',
825
826 );
827
828 C<archive> parametar is optional.
829
830 Return false on failure.
831
832 =cut
833
834 sub _add_aliases {
835 my $self = shift;
836
837 my $arg = {@_};
838
839 68 dpavlin foreach my $o (qw/list email aliases/) {
840 croak "need $o option" unless ($arg->{$o});
841 }
842 66 dpavlin
843 68 dpavlin my $aliases = $arg->{'aliases'};
844 my $email = $arg->{'email'};
845 my $list = $arg->{'list'};
846 66 dpavlin
847 unless (-e $aliases) {
848 warn "aliases file $aliases doesn't exist, creating empty\n";
849 open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
850 close($fh);
851 67 dpavlin chmod 0777, $aliases || warn "can't change permission to 0777";
852 66 dpavlin }
853
854 71 dpavlin die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
855
856 66 dpavlin my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
857
858 my $target = '';
859
860 if (my $archive = $arg->{'archive'}) {
861 $target .= "$archive, ";
862
863 if (! -e $archive) {
864 warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
865
866 open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
867 close($fh);
868 chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
869 }
870 }
871
872 # resolve my path to absolute one
873 my $self_path = abs_path($0);
874 $self_path =~ s#/[^/]+$##;
875 $self_path =~ s#/t/*$#/#;
876
877 82 dpavlin $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
878 66 dpavlin
879 82 dpavlin # remove hostname from email to make Postfix's postalias happy
880 89 dpavlin $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
881 82 dpavlin
882 68 dpavlin if ($a->exists($email)) {
883 $a->update($email, $target) or croak "can't update alias ".$a->error_check;
884 } else {
885 $a->append($email, $target) or croak "can't add alias ".$a->error_check;
886 66 dpavlin }
887
888 89 dpavlin # $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
889 70 dpavlin
890 66 dpavlin return 1;
891 }
892
893 30 dpavlin =head2 _add_list
894
895 Create new list
896
897 my $list_obj = $nos->_add_list(
898 list => 'My list',
899 47 dpavlin from => 'Outgoing from comment',
900 30 dpavlin email => 'my-list@example.com',
901 66 dpavlin aliases => '/etc/mail/mylist',
902 30 dpavlin );
903
904 Returns C<Class::DBI> object for created list.
905
906 38 dpavlin C<email> address can be with domain or without it if your
907 MTA appends it. There is no checking for validity of your
908 list e-mail. Flexibility comes with resposibility, so please
909 feed correct (and configured) return addresses.
910
911 30 dpavlin =cut
912
913 sub _add_list {
914 my $self = shift;
915
916 my $arg = {@_};
917
918 52 dpavlin my $name = lc($arg->{'list'}) || confess "can't add list without name";
919 my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
920 66 dpavlin my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
921
922 47 dpavlin my $from_addr = $arg->{'from'};
923 30 dpavlin
924 my $lists = $self->{'loader'}->find_class('lists');
925
926 66 dpavlin $self->_add_aliases(
927 list => $name,
928 email => $email,
929 aliases => $aliases,
930 68 dpavlin ) || warn "can't add alias $email for list $name";
931 66 dpavlin
932 30 dpavlin my $l = $lists->find_or_create({
933 name => $name,
934 email => $email,
935 });
936 47 dpavlin
937 30 dpavlin croak "can't add list $name\n" unless ($l);
938
939 47 dpavlin if ($from_addr && $l->from_addr ne $from_addr) {
940 $l->from_addr($from_addr);
941 $l->update;
942 }
943
944 30 dpavlin $l->dbi_commit;
945
946 return $l;
947
948 }
949
950
951 66 dpavlin
952 30 dpavlin =head2 _get_list
953
954 Get list C<Class::DBI> object.
955
956 my $list_obj = $nos->check_list('My list');
957
958 Returns false on failure.
959
960 =cut
961
962 sub _get_list {
963 my $self = shift;
964
965 my $name = shift || return;
966
967 31 dpavlin my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
968 30 dpavlin
969 52 dpavlin return $lists->search({ name => lc($name) })->first;
970 30 dpavlin }
971
972 70 dpavlin
973 =head2 _remove_alias
974
975 Remove list alias
976
977 my $ok = $nos->_remove_alias(
978 email => 'mylist@example.com',
979 aliases => '/etc/mail/mylist',
980 );
981
982 Returns true if list is removed or false if list doesn't exist. Dies in case of error.
983
984 =cut
985
986 sub _remove_alias {
987 my $self = shift;
988
989 my $arg = {@_};
990
991 my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
992 my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
993
994 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
995
996 if ($a->exists($email)) {
997 $a->delete($email) || croak "can't remove alias $email";
998 } else {
999 return 0;
1000 }
1001
1002 return 1;
1003
1004 }
1005
1006 39 dpavlin ###
1007 ### SOAP
1008 ###
1009 30 dpavlin
1010 39 dpavlin package Nos::SOAP;
1011
1012 43 dpavlin use Carp;
1013
1014 39 dpavlin =head1 SOAP methods
1015
1016 This methods are thin wrappers to provide SOAP calls. They are grouped in
1017 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
1018
1019 Usually, you want to use named variables in your SOAP calls if at all
1020 possible.
1021
1022 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
1023 you will want to use positional arguments (in same order as documented for
1024 methods below).
1025
1026 =cut
1027
1028 my $nos;
1029
1030 66 dpavlin
1031 =head2 new
1032
1033 Create new SOAP object
1034
1035 my $soap = new Nos::SOAP(
1036 dsn => 'dbi:Pg:dbname=notices',
1037 user => 'dpavlin',
1038 passwd => '',
1039 debug => 1,
1040 verbose => 1,
1041 hash_len => 8,
1042 aliases => '/etc/aliases',
1043 );
1044
1045 75 dpavlin If you are writing SOAP server (like C<soap.cgi> example), you will need to
1046 call this method once to make new instance of Nos::SOAP and specify C<dsn>
1047 and options for it.
1048
1049 66 dpavlin =cut
1050
1051 39 dpavlin sub new {
1052 90 dpavlin my $class = shift;
1053 my $self = {@_};
1054 66 dpavlin
1055 croak "need aliases parametar" unless ($self->{'aliases'});
1056
1057 39 dpavlin bless($self, $class);
1058
1059 $nos = new Nos( @_ ) || die "can't create Nos object";
1060
1061 $self ? return $self : return undef;
1062 }
1063
1064
1065 72 dpavlin =head2 CreateList
1066 39 dpavlin
1067 72 dpavlin $message_id = CreateList(
1068 39 dpavlin list => 'My list',
1069 56 dpavlin from => 'Name of my list',
1070 39 dpavlin email => 'my-list@example.com'
1071 );
1072
1073 =cut
1074
1075 72 dpavlin sub CreateList {
1076 39 dpavlin my $self = shift;
1077
1078 68 dpavlin my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1079 66 dpavlin
1080 39 dpavlin if ($_[0] !~ m/^HASH/) {
1081 72 dpavlin return $nos->create_list(
1082 56 dpavlin list => $_[0], from => $_[1], email => $_[2],
1083 66 dpavlin aliases => $aliases,
1084 39 dpavlin );
1085 } else {
1086 72 dpavlin return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1087 39 dpavlin }
1088 }
1089
1090 43 dpavlin
1091 72 dpavlin =head2 DropList
1092 63 dpavlin
1093 72 dpavlin $ok = DropList(
1094 63 dpavlin list => 'My list',
1095 );
1096
1097 =cut
1098
1099 72 dpavlin sub DropList {
1100 63 dpavlin my $self = shift;
1101
1102 70 dpavlin my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1103
1104 63 dpavlin if ($_[0] !~ m/^HASH/) {
1105 72 dpavlin return $nos->drop_list(
1106 63 dpavlin list => $_[0],
1107 70 dpavlin aliases => $aliases,
1108 63 dpavlin );
1109 } else {
1110 72 dpavlin return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1111 63 dpavlin }
1112 }
1113
1114 39 dpavlin =head2 AddMemberToList
1115
1116 $member_id = AddMemberToList(
1117 43 dpavlin list => 'My list',
1118 email => 'e-mail@example.com',
1119 58 dpavlin name => 'Full Name',
1120 ext_id => 42,
1121 39 dpavlin );
1122
1123 =cut
1124
1125 sub AddMemberToList {
1126 my $self = shift;
1127
1128 if ($_[0] !~ m/^HASH/) {
1129 return $nos->add_member_to_list(
1130 84 dpavlin list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1131 39 dpavlin );
1132 } else {
1133 return $nos->add_member_to_list( %{ shift @_ } );
1134 }
1135 }
1136
1137 43 dpavlin
1138 =head2 ListMembers
1139
1140 my @members = ListMembers(
1141 list => 'My list',
1142 );
1143
1144 Returns array of hashes with user informations, see C<list_members>.
1145
1146 =cut
1147
1148 sub ListMembers {
1149 my $self = shift;
1150
1151 my $list_name;
1152
1153 if ($_[0] !~ m/^HASH/) {
1154 $list_name = shift;
1155 } else {
1156 $list_name = $_[0]->{'list'};
1157 }
1158
1159 62 dpavlin return [ $nos->list_members( list => $list_name ) ];
1160 43 dpavlin }
1161
1162 62 dpavlin
1163 =head2 DeleteMemberFromList
1164
1165 $member_id = DeleteMemberFromList(
1166 list => 'My list',
1167 email => 'e-mail@example.com',
1168 );
1169
1170 =cut
1171
1172 sub DeleteMemberFromList {
1173 my $self = shift;
1174
1175 if ($_[0] !~ m/^HASH/) {
1176 return $nos->delete_member_from_list(
1177 list => $_[0], email => $_[1],
1178 );
1179 } else {
1180 return $nos->delete_member_from_list( %{ shift @_ } );
1181 }
1182 }
1183
1184
1185 39 dpavlin =head2 AddMessageToList
1186
1187 $message_id = AddMessageToList(
1188 list => 'My list',
1189 message => 'From: My list...'
1190 );
1191
1192 =cut
1193
1194 sub AddMessageToList {
1195 my $self = shift;
1196
1197 if ($_[0] !~ m/^HASH/) {
1198 return $nos->add_message_to_list(
1199 list => $_[0], message => $_[1],
1200 );
1201 } else {
1202 return $nos->add_message_to_list( %{ shift @_ } );
1203 }
1204 }
1205
1206 78 dpavlin =head2 MessagesReceived
1207 39 dpavlin
1208 78 dpavlin Return statistics about received messages.
1209 74 dpavlin
1210 my @result = MessagesReceived(
1211 list => 'My list',
1212 email => 'jdoe@example.com',
1213 80 dpavlin from_date => '2005-01-01 10:15:00',
1214 to_date => '2005-01-01 12:00:00',
1215 message => 0,
1216 74 dpavlin );
1217
1218 80 dpavlin You must specify C<list> or C<email> or any combination of those two. Other
1219 parametars are optional.
1220 74 dpavlin
1221 76 dpavlin For format of returned array element see C<received_messages>.
1222 74 dpavlin
1223 78 dpavlin =cut
1224
1225 sub MessagesReceived {
1226 my $self = shift;
1227
1228 if ($_[0] !~ m/^HASH/) {
1229 79 dpavlin die "need at least list or email" unless (scalar @_ < 2);
1230 85 dpavlin return \@{ $nos->received_messages(
1231 78 dpavlin list => $_[0], email => $_[1],
1232 80 dpavlin from_date => $_[2], to_date => $_[3],
1233 message => $_[4]
1234 85 dpavlin ) };
1235 78 dpavlin } else {
1236 79 dpavlin my $arg = shift;
1237 die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1238 85 dpavlin return \@{ $nos->received_messages( %{ $arg } ) };
1239 78 dpavlin }
1240 }
1241
1242 93 dpavlin =head2 SendTest
1243 78 dpavlin
1244 93 dpavlin Internal function which does e-mail sending using C<Email::Send::Test> driver.
1245 74 dpavlin
1246 93 dpavlin my $sent = SendTest( list => 'My list' );
1247 74 dpavlin
1248 93 dpavlin Returns number of messages sent
1249 90 dpavlin
1250 93 dpavlin =cut
1251 90 dpavlin
1252 93 dpavlin sub SendTest {
1253 my $self = shift;
1254 my $args = shift;
1255 die "list name required" unless ($args->{list});
1256 90 dpavlin
1257 93 dpavlin require Email::Send::Test;
1258 90 dpavlin
1259 93 dpavlin my $nr_sent = $nos->send_queued_messages(
1260 list => $args->{list},
1261 driver => 'Test',
1262 sleep => 0,
1263 verbose => 0,
1264 );
1265 90 dpavlin
1266 93 dpavlin my @emails = Email::Send::Test->emails;
1267
1268 open(my $tmp, ">/tmp/soap-debug");
1269 use Data::Dump qw/dump/;
1270 print $tmp "sent $nr_sent emails\n", dump(@emails);
1271 close($tmp);
1272
1273 return $nr_sent;
1274 90 dpavlin }
1275
1276 93 dpavlin ###
1277
1278 =head1 NOTE ON ARRAYS IN SOAP
1279
1280 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1281 seems that SOAP::Lite client thinks that it has array with one element which
1282 is array of hashes with data.
1283
1284 25 dpavlin =head1 EXPORT
1285 20 dpavlin
1286 27 dpavlin Nothing.
1287 20 dpavlin
1288 =head1 SEE ALSO
1289
1290 mailman, ezmlm, sympa, L<Mail::Salsa>
1291
1292 25 dpavlin
1293 20 dpavlin =head1 AUTHOR
1294
1295 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1296
1297 25 dpavlin
1298 20 dpavlin =head1 COPYRIGHT AND LICENSE
1299
1300 Copyright (C) 2005 by Dobrica Pavlinusic
1301
1302 This library is free software; you can redistribute it and/or modify
1303 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1304 at your option, any later version of Perl 5 you may have available.
1305
1306
1307 =cut
1308 39 dpavlin
1309 1;