/[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 49 - (show annotations)
Tue May 24 16:44:34 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 15919 byte(s)
removed unneeded --bounce flag, cleanup, added --sleep (default: 3s)

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 = $sent->search( hash => $hash )->first;
499
500 my ($message_id, $user_id) = (undef, undef); # init with NULL
501
502 if ($sent_msg) {
503 $message_id = $sent_msg->message_id || carp "no message_id";
504 $user_id = $sent_msg->user_id || carp "no user_id";
505 } else {
506 warn "can't find sender with hash $hash\n";
507 }
508
509
510 my $is_bounce = 0;
511
512 if ($return_path eq '<>' || $return_path eq '') {
513 no warnings;
514 my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
515 $arg->{'message'}, { report_non_bounces=>1 },
516 ) };
517 warn "can't check if this message is bounce!" if ($@);
518
519 $is_bounce++ if ($bounce && $bounce->is_bounce);
520 }
521
522 my $received = $self->{'loader'}->find_class('received');
523
524 my $this_received = $received->find_or_create({
525 user_id => $user_id,
526 list_id => $this_list->id,
527 message_id => $message_id,
528 message => $arg->{'message'},
529 bounced => $is_bounce,
530 }) || croak "can't insert received message";
531
532 $this_received->dbi_commit;
533
534 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
535 }
536
537
538 =head1 INTERNAL METHODS
539
540 Beware of dragons! You shouldn't need to call those methods directly.
541
542 =head2 _add_list
543
544 Create new list
545
546 my $list_obj = $nos->_add_list(
547 list => 'My list',
548 from => 'Outgoing from comment',
549 email => 'my-list@example.com',
550 );
551
552 Returns C<Class::DBI> object for created list.
553
554 C<email> address can be with domain or without it if your
555 MTA appends it. There is no checking for validity of your
556 list e-mail. Flexibility comes with resposibility, so please
557 feed correct (and configured) return addresses.
558
559 =cut
560
561 sub _add_list {
562 my $self = shift;
563
564 my $arg = {@_};
565
566 my $name = $arg->{'list'} || confess "can't add list without name";
567 my $email = $arg->{'email'} || confess "can't add list without e-mail";
568 my $from_addr = $arg->{'from'};
569
570 my $lists = $self->{'loader'}->find_class('lists');
571
572 my $l = $lists->find_or_create({
573 name => $name,
574 email => $email,
575 });
576
577 croak "can't add list $name\n" unless ($l);
578
579 if ($from_addr && $l->from_addr ne $from_addr) {
580 $l->from_addr($from_addr);
581 $l->update;
582 }
583
584 $l->dbi_commit;
585
586 return $l;
587
588 }
589
590
591 =head2 _get_list
592
593 Get list C<Class::DBI> object.
594
595 my $list_obj = $nos->check_list('My list');
596
597 Returns false on failure.
598
599 =cut
600
601 sub _get_list {
602 my $self = shift;
603
604 my $name = shift || return;
605
606 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
607
608 return $lists->search({ name => $name })->first;
609 }
610
611 ###
612 ### SOAP
613 ###
614
615 package Nos::SOAP;
616
617 use Carp;
618
619 =head1 SOAP methods
620
621 This methods are thin wrappers to provide SOAP calls. They are grouped in
622 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
623
624 Usually, you want to use named variables in your SOAP calls if at all
625 possible.
626
627 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
628 you will want to use positional arguments (in same order as documented for
629 methods below).
630
631 =cut
632
633 my $nos;
634
635 sub new {
636 my $class = shift;
637 my $self = {@_};
638 bless($self, $class);
639
640 $nos = new Nos( @_ ) || die "can't create Nos object";
641
642 $self ? return $self : return undef;
643 }
644
645
646 =head2 NewList
647
648 $message_id = NewList(
649 list => 'My list',
650 email => 'my-list@example.com'
651 );
652
653 =cut
654
655 sub NewList {
656 my $self = shift;
657
658 if ($_[0] !~ m/^HASH/) {
659 return $nos->new_list(
660 list => $_[0], email => $_[1],
661 );
662 } else {
663 return $nos->new_list( %{ shift @_ } );
664 }
665 }
666
667
668 =head2 AddMemberToList
669
670 $member_id = AddMemberToList(
671 list => 'My list',
672 email => 'e-mail@example.com',
673 name => 'Full Name'
674 );
675
676 =cut
677
678 sub AddMemberToList {
679 my $self = shift;
680
681 if ($_[0] !~ m/^HASH/) {
682 return $nos->add_member_to_list(
683 list => $_[0], email => $_[1], name => $_[2],
684 );
685 } else {
686 return $nos->add_member_to_list( %{ shift @_ } );
687 }
688 }
689
690
691 =head2 ListMembers
692
693 my @members = ListMembers(
694 list => 'My list',
695 );
696
697 Returns array of hashes with user informations, see C<list_members>.
698
699 =cut
700
701 sub ListMembers {
702 my $self = shift;
703
704 my $list_name;
705
706 if ($_[0] !~ m/^HASH/) {
707 $list_name = shift;
708 } else {
709 $list_name = $_[0]->{'list'};
710 }
711
712 return $nos->list_members( list => $list_name );
713 }
714
715 =head2 AddMessageToList
716
717 $message_id = AddMessageToList(
718 list => 'My list',
719 message => 'From: My list...'
720 );
721
722 =cut
723
724 sub AddMessageToList {
725 my $self = shift;
726
727 if ($_[0] !~ m/^HASH/) {
728 return $nos->add_message_to_list(
729 list => $_[0], message => $_[1],
730 );
731 } else {
732 return $nos->add_message_to_list( %{ shift @_ } );
733 }
734 }
735
736
737 ###
738
739 =head1 EXPORT
740
741 Nothing.
742
743 =head1 SEE ALSO
744
745 mailman, ezmlm, sympa, L<Mail::Salsa>
746
747
748 =head1 AUTHOR
749
750 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
751
752
753 =head1 COPYRIGHT AND LICENSE
754
755 Copyright (C) 2005 by Dobrica Pavlinusic
756
757 This library is free software; you can redistribute it and/or modify
758 it under the same terms as Perl itself, either Perl version 5.8.4 or,
759 at your option, any later version of Perl 5 you may have available.
760
761
762 =cut
763
764 1;

  ViewVC Help
Powered by ViewVC 1.1.26