/[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 47 - (show 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 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 $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
408 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
409
410 $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 $m_obj->header_set('To', $to) || croak "can't set To: header";
415
416 $m_obj->header_set('X-Nos-Version', $VERSION);
417 $m_obj->header_set('X-Nos-Hash', $hash);
418
419 # 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
426 $sent->create({
427 message_id => $m->message_id,
428 user_id => $u->user_id,
429 hash => $hash,
430 });
431 $sent->dbi_commit;
432 }
433 }
434 $m->all_sent(1);
435 $m->update;
436 $m->dbi_commit;
437 }
438
439 }
440
441 =head2 inbox_message
442
443 Receive single message for list's inbox.
444
445 my $ok = $nos->inbox_message(
446 list => 'My list',
447 message => $message,
448 );
449
450 =cut
451
452 sub inbox_message {
453 my $self = shift;
454
455 my $arg = {@_};
456
457 return unless ($arg->{'message'});
458 croak "need list name" unless ($arg->{'list'});
459
460 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
461
462 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 my $sent_msg = $sent->search( hash => $hash )->first;
487
488 my ($message_id, $user_id) = (undef, undef); # init with NULL
489
490 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 } else {
494 warn "can't find sender with hash $hash\n";
495 }
496
497
498 my $is_bounce = 0;
499
500 {
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
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 print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
523
524
525 warn "inbox is not yet implemented";
526 }
527
528
529 =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 from => 'Outgoing from comment',
540 email => 'my-list@example.com',
541 );
542
543 Returns C<Class::DBI> object for created list.
544
545 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 =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 my $from_addr = $arg->{'from'};
560
561 my $lists = $self->{'loader'}->find_class('lists');
562
563 my $l = $lists->find_or_create({
564 name => $name,
565 email => $email,
566 });
567
568 croak "can't add list $name\n" unless ($l);
569
570 if ($from_addr && $l->from_addr ne $from_addr) {
571 $l->from_addr($from_addr);
572 $l->update;
573 }
574
575 $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 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
598
599 return $lists->search({ name => $name })->first;
600 }
601
602 ###
603 ### SOAP
604 ###
605
606 package Nos::SOAP;
607
608 use Carp;
609
610 =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
659 =head2 AddMemberToList
660
661 $member_id = AddMemberToList(
662 list => 'My list',
663 email => 'e-mail@example.com',
664 name => 'Full Name'
665 );
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
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 =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 =head1 EXPORT
731
732 Nothing.
733
734 =head1 SEE ALSO
735
736 mailman, ezmlm, sympa, L<Mail::Salsa>
737
738
739 =head1 AUTHOR
740
741 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
742
743
744 =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
755 1;

  ViewVC Help
Powered by ViewVC 1.1.26