/[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 47 - (hide annotations)
Tue May 24 14:02:05 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 15653 byte(s)
added SMTP driver, dependency on IO::All, various fixes and improvements

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     my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
404     $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
405     $from_addr .= '<' . $from_email_only . '>';
406     my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
407 dpavlin 29
408 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
409 dpavlin 29
410 dpavlin 47 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
411     $m_obj->header_set('Sender', $from_email_only) || croak "can't set Return-Path: header";
412     $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Return-Path: header";
413     $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
414 dpavlin 32 $m_obj->header_set('To', $to) || croak "can't set To: header";
415 dpavlin 29
416 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
417     $m_obj->header_set('X-Nos-Hash', $hash);
418    
419 dpavlin 47 # really send e-mail
420     if (@email_send_options) {
421     send $email_send_driver => $m_obj->as_string, @email_send_options;
422     } else {
423     send $email_send_driver => $m_obj->as_string;
424     }
425 dpavlin 22
426     $sent->create({
427     message_id => $m->message_id,
428     user_id => $u->user_id,
429 dpavlin 36 hash => $hash,
430 dpavlin 22 });
431     $sent->dbi_commit;
432     }
433     }
434     $m->all_sent(1);
435     $m->update;
436     $m->dbi_commit;
437     }
438    
439 dpavlin 20 }
440    
441 dpavlin 29 =head2 inbox_message
442    
443     Receive single message for list's inbox.
444    
445 dpavlin 36 my $ok = $nos->inbox_message(
446     list => 'My list',
447     message => $message,
448     );
449 dpavlin 29
450     =cut
451    
452     sub inbox_message {
453     my $self = shift;
454    
455 dpavlin 36 my $arg = {@_};
456 dpavlin 29
457 dpavlin 36 return unless ($arg->{'message'});
458     croak "need list name" unless ($arg->{'list'});
459 dpavlin 29
460 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
461    
462 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
463    
464     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
465    
466     my @addrs = Email::Address->parse( $to );
467    
468     die "can't parse To: $to address\n" unless (@addrs);
469    
470     my $hl = $self->{'hash_len'} || confess "no hash_len?";
471    
472     my $hash;
473    
474     foreach my $a (@addrs) {
475     if ($a->address =~ m/\+([a-f0-9]{$hl})@/) {
476     $hash = $1;
477     last;
478     }
479     }
480    
481     croak "can't find hash in e-mail $to\n" unless ($hash);
482    
483     my $sent = $self->{'loader'}->find_class('sent');
484    
485     # will use null if no matching message_id is found
486 dpavlin 37 my $sent_msg = $sent->search( hash => $hash )->first;
487 dpavlin 36
488 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
489 dpavlin 36
490 dpavlin 37 if ($sent_msg) {
491     $message_id = $sent_msg->message_id || carp "no message_id";
492     $user_id = $sent_msg->user_id || carp "no user_id";
493 dpavlin 47 } else {
494     warn "can't find sender with hash $hash\n";
495 dpavlin 37 }
496    
497    
498     my $is_bounce = 0;
499    
500 dpavlin 47 {
501     no warnings;
502     my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
503     $arg->{'message'}, { report_non_bounces=>1 },
504     ) };
505     carp "can't check if this message is bounce!" if ($@);
506    
507     $is_bounce++ if ($bounce && $bounce->is_bounce);
508     }
509 dpavlin 37
510     my $received = $self->{'loader'}->find_class('received');
511    
512     my $this_received = $received->find_or_create({
513     user_id => $user_id,
514     list_id => $this_list->id,
515     message_id => $message_id,
516     message => $arg->{'message'},
517     bounced => $is_bounce,
518     }) || croak "can't insert received message";
519    
520     $this_received->dbi_commit;
521    
522 dpavlin 43 print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
523    
524    
525 dpavlin 36 warn "inbox is not yet implemented";
526 dpavlin 29 }
527    
528    
529 dpavlin 30 =head1 INTERNAL METHODS
530    
531     Beware of dragons! You shouldn't need to call those methods directly.
532    
533     =head2 _add_list
534    
535     Create new list
536    
537     my $list_obj = $nos->_add_list(
538     list => 'My list',
539 dpavlin 47 from => 'Outgoing from comment',
540 dpavlin 30 email => 'my-list@example.com',
541     );
542    
543     Returns C<Class::DBI> object for created list.
544    
545 dpavlin 38 C<email> address can be with domain or without it if your
546     MTA appends it. There is no checking for validity of your
547     list e-mail. Flexibility comes with resposibility, so please
548     feed correct (and configured) return addresses.
549    
550 dpavlin 30 =cut
551    
552     sub _add_list {
553     my $self = shift;
554    
555     my $arg = {@_};
556    
557     my $name = $arg->{'list'} || confess "can't add list without name";
558     my $email = $arg->{'email'} || confess "can't add list without e-mail";
559 dpavlin 47 my $from_addr = $arg->{'from'};
560 dpavlin 30
561     my $lists = $self->{'loader'}->find_class('lists');
562    
563     my $l = $lists->find_or_create({
564     name => $name,
565     email => $email,
566     });
567 dpavlin 47
568 dpavlin 30 croak "can't add list $name\n" unless ($l);
569    
570 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
571     $l->from_addr($from_addr);
572     $l->update;
573     }
574    
575 dpavlin 30 $l->dbi_commit;
576    
577     return $l;
578    
579     }
580    
581    
582     =head2 _get_list
583    
584     Get list C<Class::DBI> object.
585    
586     my $list_obj = $nos->check_list('My list');
587    
588     Returns false on failure.
589    
590     =cut
591    
592     sub _get_list {
593     my $self = shift;
594    
595     my $name = shift || return;
596    
597 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
598 dpavlin 30
599 dpavlin 31 return $lists->search({ name => $name })->first;
600 dpavlin 30 }
601    
602 dpavlin 39 ###
603     ### SOAP
604     ###
605 dpavlin 30
606 dpavlin 39 package Nos::SOAP;
607    
608 dpavlin 43 use Carp;
609    
610 dpavlin 39 =head1 SOAP methods
611    
612     This methods are thin wrappers to provide SOAP calls. They are grouped in
613     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
614    
615     Usually, you want to use named variables in your SOAP calls if at all
616     possible.
617    
618     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
619     you will want to use positional arguments (in same order as documented for
620     methods below).
621    
622     =cut
623    
624     my $nos;
625    
626     sub new {
627     my $class = shift;
628     my $self = {@_};
629     bless($self, $class);
630    
631     $nos = new Nos( @_ ) || die "can't create Nos object";
632    
633     $self ? return $self : return undef;
634     }
635    
636    
637     =head2 NewList
638    
639     $message_id = NewList(
640     list => 'My list',
641     email => 'my-list@example.com'
642     );
643    
644     =cut
645    
646     sub NewList {
647     my $self = shift;
648    
649     if ($_[0] !~ m/^HASH/) {
650     return $nos->new_list(
651     list => $_[0], email => $_[1],
652     );
653     } else {
654     return $nos->new_list( %{ shift @_ } );
655     }
656     }
657    
658 dpavlin 43
659 dpavlin 39 =head2 AddMemberToList
660    
661     $member_id = AddMemberToList(
662 dpavlin 43 list => 'My list',
663     email => 'e-mail@example.com',
664     name => 'Full Name'
665 dpavlin 39 );
666    
667     =cut
668    
669     sub AddMemberToList {
670     my $self = shift;
671    
672     if ($_[0] !~ m/^HASH/) {
673     return $nos->add_member_to_list(
674     list => $_[0], email => $_[1], name => $_[2],
675     );
676     } else {
677     return $nos->add_member_to_list( %{ shift @_ } );
678     }
679     }
680    
681 dpavlin 43
682     =head2 ListMembers
683    
684     my @members = ListMembers(
685     list => 'My list',
686     );
687    
688     Returns array of hashes with user informations, see C<list_members>.
689    
690     =cut
691    
692     sub ListMembers {
693     my $self = shift;
694    
695     my $list_name;
696    
697     if ($_[0] !~ m/^HASH/) {
698     $list_name = shift;
699     } else {
700     $list_name = $_[0]->{'list'};
701     }
702    
703     return $nos->list_members( list => $list_name );
704     }
705    
706 dpavlin 39 =head2 AddMessageToList
707    
708     $message_id = AddMessageToList(
709     list => 'My list',
710     message => 'From: My list...'
711     );
712    
713     =cut
714    
715     sub AddMessageToList {
716     my $self = shift;
717    
718     if ($_[0] !~ m/^HASH/) {
719     return $nos->add_message_to_list(
720     list => $_[0], message => $_[1],
721     );
722     } else {
723     return $nos->add_message_to_list( %{ shift @_ } );
724     }
725     }
726    
727    
728     ###
729    
730 dpavlin 25 =head1 EXPORT
731 dpavlin 20
732 dpavlin 27 Nothing.
733 dpavlin 20
734     =head1 SEE ALSO
735    
736     mailman, ezmlm, sympa, L<Mail::Salsa>
737    
738 dpavlin 25
739 dpavlin 20 =head1 AUTHOR
740    
741     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
742    
743 dpavlin 25
744 dpavlin 20 =head1 COPYRIGHT AND LICENSE
745    
746     Copyright (C) 2005 by Dobrica Pavlinusic
747    
748     This library is free software; you can redistribute it and/or modify
749     it under the same terms as Perl itself, either Perl version 5.8.4 or,
750     at your option, any later version of Perl 5 you may have available.
751    
752    
753     =cut
754 dpavlin 39
755     1;

  ViewVC Help
Powered by ViewVC 1.1.26