/[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 56 - (show annotations)
Tue Jun 21 09:14:54 2005 UTC (18 years, 8 months ago) by dpavlin
File size: 16795 byte(s)
added from address to SOAP method NewList, added ext_id to add_member_to_list

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

  ViewVC Help
Powered by ViewVC 1.1.26