/[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 48 - (show annotations)
Tue May 24 15:19:44 2005 UTC (18 years, 10 months ago) by dpavlin
File size: 15844 byte(s)
handle bounces correctly

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

  ViewVC Help
Powered by ViewVC 1.1.26