/[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 59 - (show annotations)
Tue Jun 21 20:49:27 2005 UTC (18 years, 8 months ago) by dpavlin
File size: 18113 byte(s)
added delete_member_from_list and tests for delete

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

  ViewVC Help
Powered by ViewVC 1.1.26