/[notice-sender]/trunk/Nos.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 60 - (show annotations)
Tue Jun 21 21:24:10 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 19883 byte(s)
improved documentation

1 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 our $VERSION = '0.5';
20
21 use Class::DBI::Loader;
22 use Email::Valid;
23 use Email::Send;
24 use Carp;
25 use Email::Auth::AddressHash;
26 use Email::Simple;
27 use Email::Address;
28 use Mail::DeliveryStatus::BounceParser;
29 use Class::DBI::AbstractSearch;
30
31
32 =head1 NAME
33
34 Nos - Notice Sender core module
35
36 =head1 SYNOPSIS
37
38 use Nos;
39 my $nos = new Nos();
40
41 =head1 DESCRIPTION
42
43 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
78
79 =head2 new
80
81 Create new instance specifing database, user, password and options.
82
83 my $nos = new Nos(
84 dsn => 'dbi:Pg:dbname=notices',
85 user => 'dpavlin',
86 passwd => '',
87 debug => 1,
88 verbose => 1,
89 hash_len => 8,
90 );
91
92 Parametar C<hash_len> defines length of hash which will be added to each
93 outgoing e-mail message to ensure that replies can be linked with sent e-mails.
94
95 =cut
96
97 sub new {
98 my $class = shift;
99 my $self = {@_};
100 bless($self, $class);
101
102 croak "need at least dsn" unless ($self->{'dsn'});
103
104 $self->{'loader'} = Class::DBI::Loader->new(
105 debug => $self->{'debug'},
106 dsn => $self->{'dsn'},
107 user => $self->{'user'},
108 password => $self->{'passwd'},
109 namespace => "Nos",
110 additional_classes => qw/Class::DBI::AbstractSearch/,
111 # additional_base_classes => qw/My::Stuff/,
112 relationships => 1,
113 ) || croak "can't init Class::DBI::Loader";
114
115 $self->{'hash_len'} ||= 8;
116
117 $self ? return $self : return undef;
118 }
119
120
121 =head2 new_list
122
123 Create new list. Required arguments are name of C<list> and
124 C<email> address.
125
126 $nos->new_list(
127 list => 'My list',
128 from => 'Outgoing from comment',
129 email => 'my-list@example.com',
130 );
131
132 Returns ID of newly created list.
133
134 Calls internally C<_add_list>, see details there.
135
136 =cut
137
138 sub new_list {
139 my $self = shift;
140
141 my $arg = {@_};
142
143 confess "need list name" unless ($arg->{'list'});
144 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'}) ||
150 $self->_add_list( @_ ) ||
151 return undef;
152
153 return $l->id;
154 }
155
156
157 =head2 add_member_to_list
158
159 Add new member to list
160
161 $nos->add_member_to_list(
162 list => "My list",
163 email => "john.doe@example.com",
164 name => "John A. Doe",
165 ext_id => 42,
166 );
167
168 C<name> and C<ext_id> parametars are optional.
169
170 Return member ID if user is added.
171
172 =cut
173
174 sub add_member_to_list {
175 my $self = shift;
176
177 my $arg = {@_};
178
179 my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
180 my $name = $arg->{'name'} || '';
181 my $list_name = lc($arg->{'list'}) || croak "need list name";
182 my $ext_id = $arg->{'ext_id'};
183
184 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
185
186 if (! Email::Valid->address($email)) {
187 carp "SKIPPING $name <$email>\n";
188 return 0;
189 }
190
191 carp "# $name <$email>\n" if ($self->{'verbose'});
192
193 my $users = $self->{'loader'}->find_class('users');
194 my $user_list = $self->{'loader'}->find_class('user_list');
195
196 my $this_user = $users->find_or_create({
197 email => $email,
198 }) || croak "can't find or create member\n";
199
200 if ($name && $this_user->name ne $name) {
201 $this_user->name($name || '');
202 $this_user->update;
203 }
204
205 if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
206 $this_user->ext_id($ext_id);
207 $this_user->update;
208 }
209
210 my $user_on_list = $user_list->find_or_create({
211 user_id => $this_user->id,
212 list_id => $list->id,
213 }) || croak "can't add user to list";
214
215 $list->dbi_commit;
216 $this_user->dbi_commit;
217 $user_on_list->dbi_commit;
218
219 return $this_user->id;
220 }
221
222 =head2 list_members
223
224 List all members of some list.
225
226 my @members = list_members(
227 list => 'My list',
228 );
229
230 Returns array of hashes with user informations like this:
231
232 $member = {
233 name => 'Dobrica Pavlinusic',
234 email => 'dpavlin@rot13.org
235 }
236
237 If list is not found, returns false. If there is C<ext_id> in user data,
238 it will also be returned.
239
240 =cut
241
242 sub list_members {
243 my $self = shift;
244
245 my $args = {@_};
246
247 my $list_name = lc($args->{'list'}) || confess "need list name";
248
249 my $lists = $self->{'loader'}->find_class('lists');
250 my $user_list = $self->{'loader'}->find_class('user_list');
251
252 my $this_list = $lists->search( name => $list_name )->first || return;
253
254 my @results;
255
256 foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
257 my $row = {
258 name => $user_on_list->user_id->name,
259 email => $user_on_list->user_id->email,
260 };
261
262 my $ext_id = $user_on_list->user_id->ext_id;
263 $row->{'ext_id'} = $ext_id if (defined($ext_id));
264
265 push @results, $row;
266 }
267
268 return @results;
269
270 }
271
272
273 =head2 delete_member
274
275 Delete member from database.
276
277 my $ok = delete_member(
278 name => 'Dobrica Pavlinusic'
279 );
280
281 my $ok = delete_member(
282 email => 'dpavlin@rot13.org'
283 );
284
285 Returns false if user doesn't exist.
286
287 This function will delete member from all lists (by cascading delete), so it
288 shouldn't be used lightly.
289
290 =cut
291
292 sub delete_member {
293 my $self = shift;
294
295 my $args = {@_};
296
297 croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
298
299 $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
300
301 my $key = 'name';
302 $key = 'email' if ($args->{'email'});
303
304 my $users = $self->{'loader'}->find_class('users');
305
306 my $this_user = $users->search( $key => $args->{$key} )->first || return;
307
308 $this_user->delete || croak "can't delete user\n";
309
310 return $users->dbi_commit || croak "can't commit";
311 }
312
313 =head2 delete_member_from_list
314
315 Delete member from particular list.
316
317 my $ok = delete_member_from_list(
318 list => 'My list',
319 email => 'dpavlin@rot13.org',
320 );
321
322 Returns false if user doesn't exist on that particular list.
323
324 It will die if list or user doesn't exist. You have been warned (you might
325 want to eval this functon to prevent it from croaking).
326
327 =cut
328
329 sub delete_member_from_list {
330 my $self = shift;
331
332 my $args = {@_};
333
334 croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
335
336 $args->{'list'} = lc($args->{'list'});
337 $args->{'email'} = lc($args->{'email'});
338
339 my $user = $self->{'loader'}->find_class('users');
340 my $list = $self->{'loader'}->find_class('lists');
341 my $user_list = $self->{'loader'}->find_class('user_list');
342
343 my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
344 my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
345
346 my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_list->id )->first || return;
347
348 $this_user_list->delete || croak "can't delete user from list\n";
349
350 return $user_list->dbi_commit || croak "can't commit";
351 }
352
353 =head2 add_message_to_list
354
355 Adds message to one list's queue for later sending.
356
357 $nos->add_message_to_list(
358 list => 'My list',
359 message => 'Subject: welcome to list
360
361 This is example message
362 ',
363 );
364
365 On success returns ID of newly created (or existing) message.
366
367 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
368 will be automatically generated, but if you want to use own headers, just
369 include them in messages.
370
371 =cut
372
373 sub add_message_to_list {
374 my $self = shift;
375
376 my $args = {@_};
377
378 my $list_name = lc($args->{'list'}) || confess "need list name";
379 my $message_text = $args->{'message'} || croak "need message";
380
381 my $m = Email::Simple->new($message_text) || croak "can't parse message";
382
383 unless( $m->header('Subject') ) {
384 warn "message doesn't have Subject header\n";
385 return;
386 }
387
388 my $lists = $self->{'loader'}->find_class('lists');
389
390 my $this_list = $lists->search(
391 name => $list_name,
392 )->first || croak "can't find list $list_name";
393
394 my $messages = $self->{'loader'}->find_class('messages');
395
396 my $this_message = $messages->find_or_create({
397 message => $message_text
398 }) || croak "can't insert message";
399
400 $this_message->dbi_commit() || croak "can't add message";
401
402 my $queue = $self->{'loader'}->find_class('queue');
403
404 $queue->find_or_create({
405 message_id => $this_message->id,
406 list_id => $this_list->id,
407 }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
408
409 $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
410
411 return $this_message->id;
412 }
413
414
415 =head2 send_queued_messages
416
417 Send queued messages or just ones for selected list
418
419 $nos->send_queued_messages(
420 list => 'My list',
421 driver => 'smtp',
422 sleep => 3,
423 );
424
425 Second option is driver which will be used for e-mail delivery. If not
426 specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
427
428 Other valid drivers are:
429
430 =over 10
431
432 =item smtp
433
434 Send e-mail using SMTP server at 127.0.0.1
435
436 =back
437
438 Default sleep wait between two messages is 3 seconds.
439
440 =cut
441
442 sub send_queued_messages {
443 my $self = shift;
444
445 my $arg = {@_};
446
447 my $list_name = lc($arg->{'list'}) || '';
448 my $driver = $arg->{'driver'} || '';
449 my $sleep = $arg->{'sleep'};
450 $sleep ||= 3 unless defined($sleep);
451
452 my $email_send_driver = 'Email::Send::IO';
453 my @email_send_options;
454
455 if (lc($driver) eq 'smtp') {
456 $email_send_driver = 'Email::Send::SMTP';
457 @email_send_options = ['127.0.0.1'];
458 } else {
459 warn "dumping all messages to STDERR\n";
460 }
461
462 my $lists = $self->{'loader'}->find_class('lists');
463 my $queue = $self->{'loader'}->find_class('queue');
464 my $user_list = $self->{'loader'}->find_class('user_list');
465 my $sent = $self->{'loader'}->find_class('sent');
466
467 my $my_q;
468 if ($list_name ne '') {
469 my $l_id = $lists->search_like( name => $list_name )->first ||
470 croak "can't find list $list_name";
471 $my_q = $queue->search_like( list_id => $l_id ) ||
472 croak "can't find list $list_name";
473 } else {
474 $my_q = $queue->retrieve_all;
475 }
476
477 while (my $m = $my_q->next) {
478 next if ($m->all_sent);
479
480 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
481 my $msg = $m->message_id->message;
482
483 foreach my $u ($user_list->search(list_id => $m->list_id)) {
484
485 my $to_email = $u->user_id->email;
486
487 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
488
489 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
490 print "SKIP $to_email message allready sent\n";
491 } else {
492 print "=> $to_email\n";
493
494 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
495 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
496
497 my $hash = $auth->generate_hash( $to_email );
498
499 my $from_addr;
500 my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
501
502 $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
503 $from_addr .= '<' . $from_email_only . '>';
504 my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
505
506 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
507
508 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
509 $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
510 $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
511 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
512 $m_obj->header_set('To', $to) || croak "can't set To: header";
513
514 $m_obj->header_set('X-Nos-Version', $VERSION);
515 $m_obj->header_set('X-Nos-Hash', $hash);
516
517 # really send e-mail
518 if (@email_send_options) {
519 send $email_send_driver => $m_obj->as_string, @email_send_options;
520 } else {
521 send $email_send_driver => $m_obj->as_string;
522 }
523
524 $sent->create({
525 message_id => $m->message_id,
526 user_id => $u->user_id,
527 hash => $hash,
528 });
529 $sent->dbi_commit;
530
531 if ($sleep) {
532 warn "sleeping $sleep seconds\n";
533 sleep($sleep);
534 }
535 }
536 }
537 $m->all_sent(1);
538 $m->update;
539 $m->dbi_commit;
540 }
541
542 }
543
544 =head2 inbox_message
545
546 Receive single message for list's inbox.
547
548 my $ok = $nos->inbox_message(
549 list => 'My list',
550 message => $message,
551 );
552
553 This method is used by C<sender.pl> when receiving e-mail messages.
554
555 =cut
556
557 sub inbox_message {
558 my $self = shift;
559
560 my $arg = {@_};
561
562 return unless ($arg->{'message'});
563 croak "need list name" unless ($arg->{'list'});
564
565 $arg->{'list'} = lc($arg->{'list'});
566
567 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
568
569 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
570
571 my $to = $m->header('To') || die "can't find To: address in incomming message\n";
572
573 my $return_path = $m->header('Return-Path') || '';
574
575 my @addrs = Email::Address->parse( $to );
576
577 die "can't parse To: $to address\n" unless (@addrs);
578
579 my $hl = $self->{'hash_len'} || confess "no hash_len?";
580
581 my $hash;
582
583 foreach my $a (@addrs) {
584 if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
585 $hash = $1;
586 last;
587 }
588 }
589
590 #warn "can't find hash in e-mail $to\n" unless ($hash);
591
592 my $sent = $self->{'loader'}->find_class('sent');
593
594 # will use null if no matching message_id is found
595 my $sent_msg;
596 $sent_msg = $sent->search( hash => $hash )->first if ($hash);
597
598 my ($message_id, $user_id) = (undef, undef); # init with NULL
599
600 if ($sent_msg) {
601 $message_id = $sent_msg->message_id || carp "no message_id";
602 $user_id = $sent_msg->user_id || carp "no user_id";
603 } else {
604 #warn "can't find sender with hash $hash\n";
605 my $users = $self->{'loader'}->find_class('users');
606 my $from = $m->header('From');
607 $from = $1 if ($from =~ m/<(.*)>/);
608 my $this_user = $users->search( email => lc($from) )->first;
609 $user_id = $this_user->id if ($this_user);
610 }
611
612
613 my $is_bounce = 0;
614
615 if ($return_path eq '<>' || $return_path eq '') {
616 no warnings;
617 my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
618 $arg->{'message'}, { report_non_bounces=>1 },
619 ) };
620 #warn "can't check if this message is bounce!" if ($@);
621
622 $is_bounce++ if ($bounce && $bounce->is_bounce);
623 }
624
625 my $received = $self->{'loader'}->find_class('received');
626
627 my $this_received = $received->find_or_create({
628 user_id => $user_id,
629 list_id => $this_list->id,
630 message_id => $message_id,
631 message => $arg->{'message'},
632 bounced => $is_bounce,
633 }) || croak "can't insert received message";
634
635 $this_received->dbi_commit;
636
637 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
638 }
639
640
641 =head1 INTERNAL METHODS
642
643 Beware of dragons! You shouldn't need to call those methods directly.
644
645 =head2 _add_list
646
647 Create new list
648
649 my $list_obj = $nos->_add_list(
650 list => 'My list',
651 from => 'Outgoing from comment',
652 email => 'my-list@example.com',
653 );
654
655 Returns C<Class::DBI> object for created list.
656
657 C<email> address can be with domain or without it if your
658 MTA appends it. There is no checking for validity of your
659 list e-mail. Flexibility comes with resposibility, so please
660 feed correct (and configured) return addresses.
661
662 =cut
663
664 sub _add_list {
665 my $self = shift;
666
667 my $arg = {@_};
668
669 my $name = lc($arg->{'list'}) || confess "can't add list without name";
670 my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
671 my $from_addr = $arg->{'from'};
672
673 my $lists = $self->{'loader'}->find_class('lists');
674
675 my $l = $lists->find_or_create({
676 name => $name,
677 email => $email,
678 });
679
680 croak "can't add list $name\n" unless ($l);
681
682 if ($from_addr && $l->from_addr ne $from_addr) {
683 $l->from_addr($from_addr);
684 $l->update;
685 }
686
687 $l->dbi_commit;
688
689 return $l;
690
691 }
692
693
694 =head2 _get_list
695
696 Get list C<Class::DBI> object.
697
698 my $list_obj = $nos->check_list('My list');
699
700 Returns false on failure.
701
702 =cut
703
704 sub _get_list {
705 my $self = shift;
706
707 my $name = shift || return;
708
709 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
710
711 return $lists->search({ name => lc($name) })->first;
712 }
713
714 ###
715 ### SOAP
716 ###
717
718 package Nos::SOAP;
719
720 use Carp;
721
722 =head1 SOAP methods
723
724 This methods are thin wrappers to provide SOAP calls. They are grouped in
725 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
726
727 Usually, you want to use named variables in your SOAP calls if at all
728 possible.
729
730 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
731 you will want to use positional arguments (in same order as documented for
732 methods below).
733
734 =cut
735
736 my $nos;
737
738 sub new {
739 my $class = shift;
740 my $self = {@_};
741 bless($self, $class);
742
743 $nos = new Nos( @_ ) || die "can't create Nos object";
744
745 $self ? return $self : return undef;
746 }
747
748
749 =head2 NewList
750
751 $message_id = NewList(
752 list => 'My list',
753 from => 'Name of my list',
754 email => 'my-list@example.com'
755 );
756
757 =cut
758
759 sub NewList {
760 my $self = shift;
761
762 if ($_[0] !~ m/^HASH/) {
763 return $nos->new_list(
764 list => $_[0], from => $_[1], email => $_[2],
765 );
766 } else {
767 return $nos->new_list( %{ shift @_ } );
768 }
769 }
770
771
772 =head2 AddMemberToList
773
774 $member_id = AddMemberToList(
775 list => 'My list',
776 email => 'e-mail@example.com',
777 name => 'Full Name',
778 ext_id => 42,
779 );
780
781 =cut
782
783 sub AddMemberToList {
784 my $self = shift;
785
786 if ($_[0] !~ m/^HASH/) {
787 return $nos->add_member_to_list(
788 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
789 );
790 } else {
791 return $nos->add_member_to_list( %{ shift @_ } );
792 }
793 }
794
795
796 =head2 ListMembers
797
798 my @members = ListMembers(
799 list => 'My list',
800 );
801
802 Returns array of hashes with user informations, see C<list_members>.
803
804 =cut
805
806 sub ListMembers {
807 my $self = shift;
808
809 my $list_name;
810
811 if ($_[0] !~ m/^HASH/) {
812 $list_name = shift;
813 } else {
814 $list_name = $_[0]->{'list'};
815 }
816
817 return $nos->list_members( list => $list_name );
818 }
819
820 =head2 AddMessageToList
821
822 $message_id = AddMessageToList(
823 list => 'My list',
824 message => 'From: My list...'
825 );
826
827 =cut
828
829 sub AddMessageToList {
830 my $self = shift;
831
832 if ($_[0] !~ m/^HASH/) {
833 return $nos->add_message_to_list(
834 list => $_[0], message => $_[1],
835 );
836 } else {
837 return $nos->add_message_to_list( %{ shift @_ } );
838 }
839 }
840
841
842 ###
843
844 =head1 EXPORT
845
846 Nothing.
847
848 =head1 SEE ALSO
849
850 mailman, ezmlm, sympa, L<Mail::Salsa>
851
852
853 =head1 AUTHOR
854
855 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
856
857
858 =head1 COPYRIGHT AND LICENSE
859
860 Copyright (C) 2005 by Dobrica Pavlinusic
861
862 This library is free software; you can redistribute it and/or modify
863 it under the same terms as Perl itself, either Perl version 5.8.4 or,
864 at your option, any later version of Perl 5 you may have available.
865
866
867 =cut
868
869 1;

  ViewVC Help
Powered by ViewVC 1.1.26