/[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 50 - (show annotations)
Tue May 24 17:04:01 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 16174 byte(s)
less warnings to prevent bounce generation

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

  ViewVC Help
Powered by ViewVC 1.1.26