/[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

Annotation of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 48 - (hide annotations)
Tue May 24 15:19:44 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 15844 byte(s)
handle bounces correctly

1 dpavlin 20 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 dpavlin 45 our $VERSION = '0.4';
20 dpavlin 20
21     use Class::DBI::Loader;
22     use Email::Valid;
23     use Email::Send;
24     use Carp;
25 dpavlin 29 use Email::Auth::AddressHash;
26     use Email::Simple;
27 dpavlin 36 use Email::Address;
28 dpavlin 37 use Mail::DeliveryStatus::BounceParser;
29 dpavlin 29 use Data::Dumper;
30 dpavlin 20
31 dpavlin 47 my $email_send_driver = 'Email::Send::IO';
32     my @email_send_options;
33    
34     #$email_send_driver = 'Sendmail';
35    
36    
37 dpavlin 20 =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 dpavlin 36 hash_len => 8,
63 dpavlin 20 );
64    
65 dpavlin 38 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 dpavlin 36
68 dpavlin 20 =cut
69    
70     sub new {
71     my $class = shift;
72     my $self = {@_};
73     bless($self, $class);
74    
75 dpavlin 22 croak "need at least dsn" unless ($self->{'dsn'});
76    
77 dpavlin 20 $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 dpavlin 22 ) || croak "can't init Class::DBI::Loader";
87 dpavlin 20
88 dpavlin 36 $self->{'hash_len'} ||= 8;
89    
90 dpavlin 20 $self ? return $self : return undef;
91     }
92    
93 dpavlin 30
94 dpavlin 33 =head2 new_list
95    
96 dpavlin 38 Create new list. Required arguments are name of C<list> and
97     C<email> address.
98 dpavlin 33
99     $nos->new_list(
100 dpavlin 38 list => 'My list',
101 dpavlin 47 from => 'Outgoing from comment',
102 dpavlin 33 email => 'my-list@example.com',
103     );
104    
105     Returns ID of newly created list.
106    
107 dpavlin 38 Calls internally L<_add_list>, see details there.
108    
109 dpavlin 33 =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 dpavlin 23 =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 dpavlin 27 Return member ID if user is added.
140 dpavlin 23
141     =cut
142    
143     sub add_member_to_list {
144     my $self = shift;
145    
146     my $arg = {@_};
147    
148 dpavlin 30 my $email = $arg->{'email'} || croak "can't add user without e-mail";
149 dpavlin 23 my $name = $arg->{'name'} || '';
150 dpavlin 30 my $list_name = $arg->{'list'} || croak "need list name";
151 dpavlin 23
152 dpavlin 30 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
153    
154 dpavlin 23 if (! Email::Valid->address($email)) {
155 dpavlin 33 carp "SKIPPING $name <$email>\n";
156 dpavlin 23 return 0;
157     }
158    
159 dpavlin 29 carp "# $name <$email>\n" if ($self->{'verbose'});
160 dpavlin 23
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 dpavlin 45 if ($name && $this_user->name ne $name) {
169     $this_user->name($name || '');
170 dpavlin 33 $this_user->update;
171     }
172    
173 dpavlin 23 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 dpavlin 27 return $this_user->id;
183 dpavlin 23 }
184    
185 dpavlin 43 =head2 list_members
186    
187 dpavlin 45 List all members of some list.
188    
189 dpavlin 43 my @members = list_members(
190     list => 'My list',
191     );
192    
193     Returns array of hashes with user informations like this:
194    
195     $member = {
196 dpavlin 45 name => 'Dobrica Pavlinusic',
197 dpavlin 43 email => 'dpavlin@rot13.org
198     }
199    
200 dpavlin 45 If list is not found, returns false.
201    
202 dpavlin 43 =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 dpavlin 45 my $this_list = $lists->search( name => $list_name )->first || return;
215 dpavlin 43
216     my @results;
217    
218     foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
219     my $row = {
220 dpavlin 45 name => $user_on_list->user_id->name,
221 dpavlin 43 email => $user_on_list->user_id->email,
222     };
223    
224     push @results, $row;
225     }
226    
227     return @results;
228    
229     }
230    
231    
232 dpavlin 45 =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 dpavlin 29 =head2 add_message_to_list
270 dpavlin 24
271     Adds message to one list's queue for later sending.
272    
273 dpavlin 29 $nos->add_message_to_list(
274 dpavlin 24 list => 'My list',
275 dpavlin 36 message => 'Subject: welcome to list
276 dpavlin 38
277 dpavlin 24 This is example message
278     ',
279     );
280    
281     On success returns ID of newly created (or existing) message.
282    
283 dpavlin 36 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 dpavlin 24 =cut
288    
289 dpavlin 29 sub add_message_to_list {
290 dpavlin 24 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 dpavlin 29 my $m = Email::Simple->new($message_text) || croak "can't parse message";
298    
299 dpavlin 32 unless( $m->header('Subject') ) {
300     warn "message doesn't have Subject header\n";
301     return;
302     }
303 dpavlin 29
304 dpavlin 24 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 dpavlin 22 =head2 send_queued_messages
332 dpavlin 20
333 dpavlin 22 Send queued messages or just ones for selected list
334 dpavlin 20
335 dpavlin 47 $nos->send_queued_messages("My list",'smtp');
336 dpavlin 20
337 dpavlin 47 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 dpavlin 21 =cut
351 dpavlin 20
352 dpavlin 22 sub send_queued_messages {
353 dpavlin 21 my $self = shift;
354 dpavlin 20
355 dpavlin 22 my $list_name = shift;
356 dpavlin 20
357 dpavlin 47 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 dpavlin 22 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 dpavlin 20
370 dpavlin 22 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 dpavlin 20
380 dpavlin 22 while (my $m = $my_q->next) {
381     next if ($m->all_sent);
382 dpavlin 20
383 dpavlin 22 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 dpavlin 20
386 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
387 dpavlin 20
388 dpavlin 29 my $to_email = $u->user_id->email;
389    
390 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
391    
392 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
393 dpavlin 29 print "SKIP $to_email message allready sent\n";
394 dpavlin 22 } else {
395 dpavlin 32 print "=> $to_email\n";
396 dpavlin 20
397 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
398 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
399 dpavlin 32
400 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
401 dpavlin 20
402 dpavlin 47 my $from_addr;
403 dpavlin 48 my $email_hash = "+" . $hash . ( $domain ? '@' . $domain : '');
404     my $from_email_only = $from . $email_hash;
405     my $from_bounce = $from . '-bounce' . $email_hash;
406    
407 dpavlin 47 $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 dpavlin 29
411 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
412 dpavlin 29
413 dpavlin 48 $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 dpavlin 47 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
417 dpavlin 32 $m_obj->header_set('To', $to) || croak "can't set To: header";
418 dpavlin 29
419 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
420     $m_obj->header_set('X-Nos-Hash', $hash);
421    
422 dpavlin 47 # 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 dpavlin 22
429     $sent->create({
430     message_id => $m->message_id,
431     user_id => $u->user_id,
432 dpavlin 36 hash => $hash,
433 dpavlin 22 });
434     $sent->dbi_commit;
435     }
436     }
437     $m->all_sent(1);
438     $m->update;
439     $m->dbi_commit;
440     }
441    
442 dpavlin 20 }
443    
444 dpavlin 29 =head2 inbox_message
445    
446     Receive single message for list's inbox.
447    
448 dpavlin 36 my $ok = $nos->inbox_message(
449     list => 'My list',
450     message => $message,
451     );
452 dpavlin 29
453     =cut
454    
455     sub inbox_message {
456     my $self = shift;
457    
458 dpavlin 36 my $arg = {@_};
459 dpavlin 29
460 dpavlin 36 return unless ($arg->{'message'});
461     croak "need list name" unless ($arg->{'list'});
462 dpavlin 29
463 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
464    
465 dpavlin 36 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 dpavlin 48 my $return_path = $m->header('Return-Path') || '';
470    
471 dpavlin 36 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 dpavlin 48 warn "can't find hash in e-mail $to\n" unless ($hash);
487 dpavlin 36
488     my $sent = $self->{'loader'}->find_class('sent');
489    
490     # will use null if no matching message_id is found
491 dpavlin 37 my $sent_msg = $sent->search( hash => $hash )->first;
492 dpavlin 36
493 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
494 dpavlin 36
495 dpavlin 37 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 dpavlin 47 } else {
499     warn "can't find sender with hash $hash\n";
500 dpavlin 37 }
501    
502    
503     my $is_bounce = 0;
504    
505 dpavlin 48 if ($arg->{'bounce'} || $return_path eq '<>' || $return_path eq '') {
506 dpavlin 47 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 dpavlin 37
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 dpavlin 43 print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
528    
529    
530 dpavlin 36 warn "inbox is not yet implemented";
531 dpavlin 29 }
532    
533    
534 dpavlin 30 =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 dpavlin 47 from => 'Outgoing from comment',
545 dpavlin 30 email => 'my-list@example.com',
546     );
547    
548     Returns C<Class::DBI> object for created list.
549    
550 dpavlin 38 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 dpavlin 30 =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 dpavlin 47 my $from_addr = $arg->{'from'};
565 dpavlin 30
566     my $lists = $self->{'loader'}->find_class('lists');
567    
568     my $l = $lists->find_or_create({
569     name => $name,
570     email => $email,
571     });
572 dpavlin 47
573 dpavlin 30 croak "can't add list $name\n" unless ($l);
574    
575 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
576     $l->from_addr($from_addr);
577     $l->update;
578     }
579    
580 dpavlin 30 $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 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
603 dpavlin 30
604 dpavlin 31 return $lists->search({ name => $name })->first;
605 dpavlin 30 }
606    
607 dpavlin 39 ###
608     ### SOAP
609     ###
610 dpavlin 30
611 dpavlin 39 package Nos::SOAP;
612    
613 dpavlin 43 use Carp;
614    
615 dpavlin 39 =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 dpavlin 43
664 dpavlin 39 =head2 AddMemberToList
665    
666     $member_id = AddMemberToList(
667 dpavlin 43 list => 'My list',
668     email => 'e-mail@example.com',
669     name => 'Full Name'
670 dpavlin 39 );
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 dpavlin 43
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 dpavlin 39 =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 dpavlin 25 =head1 EXPORT
736 dpavlin 20
737 dpavlin 27 Nothing.
738 dpavlin 20
739     =head1 SEE ALSO
740    
741     mailman, ezmlm, sympa, L<Mail::Salsa>
742    
743 dpavlin 25
744 dpavlin 20 =head1 AUTHOR
745    
746     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
747    
748 dpavlin 25
749 dpavlin 20 =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 dpavlin 39
760     1;

  ViewVC Help
Powered by ViewVC 1.1.26