/[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 52 - (show annotations)
Wed May 25 15:03:10 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 16402 byte(s)
list names and e-mail addresses are now forced to lowercase

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

  ViewVC Help
Powered by ViewVC 1.1.26